[Git][ghc/ghc][wip/joachim/issue16624] 3 commits: ErrUtils: Emit progress messages to eventlog

[Joachim Breitner]

Joachim Breitner pushed to branch wip/joachim/issue16624 at Glasgow Haskell Compiler / GHC


Commits:
1bef62c3 by Ben Gamari at 2019-05-01T00:41:42Z
ErrUtils: Emit progress messages to eventlog

- - - - -
ebfa3528 by Ben Gamari at 2019-05-01T00:41:42Z
Emit GHC timing events to eventlog

- - - - -
30cc1fcd by Joachim Breitner at 2019-05-03T07:44:45Z
Don't let heap_view_closurePtrs fall over CONSTR_NOCAF

this fixes #16624

- - - - -


3 changed files:

- compiler/main/ErrUtils.hs
- libraries/ghc-heap/tests/heap_all.hs
- rts/Heap.c


Changes:

=====================================
compiler/main/ErrUtils.hs
=====================================
@@ -81,6 +81,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
@@ -608,9 +609,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
@@ -651,10 +653,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


=====================================
libraries/ghc-heap/tests/heap_all.hs
=====================================
@@ -41,6 +41,16 @@ exConstrClosure = ConstrClosure
     , name = "Just"
     }
 
+exConstrNoCafClosure :: Closure
+exConstrNoCafClosure = ConstrClosure
+    { info = exItbl{tipe=CONSTR_NOCAF, ptrs=0, nptrs=3}
+    , ptrArgs = []
+    , dataArgs = [0,1,2]
+    , pkg = "main"
+    , modl = "Main"
+    , name = "ConstrNoCaf"
+    }
+
 exFunClosure :: Closure
 exFunClosure = FunClosure
     { info = exItbl{tipe=FUN_0_1, ptrs=0, nptrs=1}
@@ -189,6 +199,12 @@ data MBA = MBA (MutableByteArray# RealWorld)
 data B = B BCO#
 data APC a = APC a
 
+data ConstrNoCaf = ConstrNoCaf Int# Int# Int#
+
+staticClosure :: ConstrNoCaf
+staticClosure = ConstrNoCaf 0# 1# 2#
+{-# NOINLINE staticClosure #-}
+
 main :: IO ()
 main = do
 
@@ -224,6 +240,13 @@ main = do
     getClosureData con >>=
         assertClosuresEq exConstrClosure
 
+    evaluate staticClosure
+    performGC
+
+    -- Static Constructor
+    getClosureData staticClosure >>=
+        assertClosuresEq exConstrNoCafClosure
+
     -- Function
     let !fun = \x -> x + 1
     getClosureData fun >>=


=====================================
rts/Heap.c
=====================================
@@ -110,6 +110,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
         case CONSTR_1_1:
         case CONSTR_0_2:
         case CONSTR:
+        case CONSTR_NOCAF:
 
 
         case PRIM:
@@ -204,7 +205,7 @@ StgMutArrPtrs *heap_view_closurePtrs(Capability *cap, StgClosure *closure) {
             break;
 
         default:
-            fprintf(stderr,"closurePtrs: Cannot handle type %s yet\n",
+            fprintf(stderr,"heap_view_closurePtrs: Cannot handle type %s yet\n",
                            closure_type_names[info->type]);
             break;
     }



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/b9722655fca5bf5b12dbdac31b1463e1c317a44f...30cc1fcd2911653f1141eaea79dfa5671989c21e

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/compare/b9722655fca5bf5b12dbdac31b1463e1c317a44f...30cc1fcd2911653f1141eaea79dfa5671989c21e
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/20190503/2657d582/attachment-0001.html>