[commit: ghc] wip/erikd/t11978b: rts: Specialize `overwritingClosure` for `MSG_THROWTO` (bc07fe0)

git at git.haskell.org git at git.haskell.org
Wed May 4 01:16:21 UTC 2016


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

On branch  : wip/erikd/t11978b
Link       : http://ghc.haskell.org/trac/ghc/changeset/bc07fe011abb2defaa9e3a4721f9de9e3a036835/ghc

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

commit bc07fe011abb2defaa9e3a4721f9de9e3a036835
Author: Erik de Castro Lopo <erikd at mega-nerd.com>
Date:   Tue May 3 21:13:17 2016 +1000

    rts: Specialize `overwritingClosure` for `MSG_THROWTO`
    
    The function `executeMessage` replaces the `header.info` pointer with
    a `WHITEHOLE` passes it to `throwToMsg` and then passes it to
    `doneWithMsgThrowTo` which calls `overwritingClosure` on it. However,
    `overwritingClosure` needs to know the size of the closure which is
    based on the `header.info` pointer. Unfortunately, the `header.info`
    pointer can't be reset to `MSG_THROWTO` or it might cause race
    conditions.
    
    The solution suggested by Simon Marlow is to add and use a function
    `overwritingClosureWithSize` that takes an explicit size parameter.


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

bc07fe011abb2defaa9e3a4721f9de9e3a036835
 includes/rts/storage/ClosureMacros.h               | 26 ++++++++++++++++++++++
 rts/Messages.h                                     |  2 +-
 testsuite/config/ghc                               |  3 +++
 testsuite/tests/profiling/should_run/T11978b.hs    | 22 ++++++++++++++++++
 .../tests/profiling/should_run/T11978b.stdout      |  2 ++
 testsuite/tests/profiling/should_run/all.T         |  4 ++++
 6 files changed, 58 insertions(+), 1 deletion(-)

diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h
index 03589f2..4f38c76 100644
--- a/includes/rts/storage/ClosureMacros.h
+++ b/includes/rts/storage/ClosureMacros.h
@@ -497,10 +497,12 @@ INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
 
 #if ZERO_SLOP_FOR_LDV_PROF || ZERO_SLOP_FOR_SANITY_CHECK
 #define OVERWRITING_CLOSURE(c) overwritingClosure(c)
+#define OVERWRITING_CLOSURE_SIZE(c,s) overwritingClosureWithSize(c,s)
 #define OVERWRITING_CLOSURE_OFS(c,n) \
     overwritingClosureOfs(c,n)
 #else
 #define OVERWRITING_CLOSURE(c) /* nothing */
+#define OVERWRITING_CLOSURE_SIZE(c,s) /* nothing */
 #define OVERWRITING_CLOSURE_OFS(c,n) /* nothing */
 #endif
 
@@ -508,6 +510,28 @@ INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
 void LDV_recordDead (StgClosure *c, nat size);
 #endif
 
+EXTERN_INLINE void overwritingClosureWithSize (StgClosure *p, nat size);
+EXTERN_INLINE void overwritingClosureWithSize (StgClosure *p, nat size)
+{
+    nat i;
+
+#if ZERO_SLOP_FOR_LDV_PROF && !ZERO_SLOP_FOR_SANITY_CHECK
+    // see Note [zeroing slop], also #8402
+    if (era <= 0) return;
+#endif
+
+    // For LDV profiling, we need to record the closure as dead
+#if defined(PROFILING)
+    LDV_recordDead(p, size);
+#endif
+
+    ASSERT(size >= sizeofW(StgThunkHeader));
+
+    for (i = 0; i < size - sizeofW(StgThunkHeader); i++) {
+        ((StgThunk *)(p))->payload[i] = 0;
+    }
+}
+
 EXTERN_INLINE void overwritingClosure (StgClosure *p);
 EXTERN_INLINE void overwritingClosure (StgClosure *p)
 {
@@ -525,6 +549,8 @@ EXTERN_INLINE void overwritingClosure (StgClosure *p)
     LDV_recordDead(p, size);
 #endif
 
+    ASSERT(size >= sizeofW(StgThunkHeader));
+
     for (i = 0; i < size - sizeofW(StgThunkHeader); i++) {
         ((StgThunk *)(p))->payload[i] = 0;
     }
diff --git a/rts/Messages.h b/rts/Messages.h
index 4121364..69319c2 100644
--- a/rts/Messages.h
+++ b/rts/Messages.h
@@ -22,7 +22,7 @@ void sendMessage    (Capability *from_cap, Capability *to_cap, Message *msg);
 INLINE_HEADER void
 doneWithMsgThrowTo (MessageThrowTo *m)
 {
-    OVERWRITING_CLOSURE((StgClosure*)m);
+    OVERWRITING_CLOSURE_SIZE((StgClosure*)m, sizeofW(MessageThrowTo));
     unlockClosure((StgClosure*)m, &stg_MSG_NULL_info);
     LDV_RECORD_CREATE(m);
 }
diff --git a/testsuite/config/ghc b/testsuite/config/ghc
index 595415a..347b8b1 100644
--- a/testsuite/config/ghc
+++ b/testsuite/config/ghc
@@ -75,6 +75,7 @@ config.ghc_dynamic = ghc_dynamic
 
 if (ghc_with_profiling == 1 and ghc_with_threaded_rts == 1):
     config.run_ways.append('profthreaded')
+    config.run_ways.append('profthrdebug')
 
 if (ghc_with_llvm == 1):
     config.compile_ways.append('optllvm')
@@ -108,6 +109,7 @@ config.way_flags = lambda name : {
     'prof_hr'      : ['-O', '-prof', '-static', '-auto-all'],
     'dyn'          : ['-O', '-dynamic'],
     'static'       : ['-O', '-static'],
+    'profthrdebug' : ['-O', '-prof', '-static', '-threaded', '-debug'],
     'debug'        : ['-O', '-g', '-dannot-lint'],
     # llvm variants...
     'profllvm'         : ['-prof', '-static', '-auto-all', '-fllvm'],
@@ -138,6 +140,7 @@ config.way_rts_flags = {
     'prof_hd'      : ['-hd'],
     'prof_hy'      : ['-hy'],
     'prof_hr'      : ['-hr'],
+    'profthrdebug' : ['-p'],
     'dyn'          : [],
     'static'       : [],
     'debug'        : [],
diff --git a/testsuite/tests/profiling/should_run/T11978b.hs b/testsuite/tests/profiling/should_run/T11978b.hs
new file mode 100644
index 0000000..226e7d1
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11978b.hs
@@ -0,0 +1,22 @@
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad
+
+main :: IO ()
+main = do
+    putStrLn "Start ..."
+    mvar <- newMVar (0 :: Int)
+
+    let count = 50
+
+    forM_ [ 1 .. count ] $ const $ forkIO $ do
+            threadDelay 100
+            i <- takeMVar mvar
+            putMVar mvar $! i + 1
+
+    threadDelay 1000000
+    end <- takeMVar mvar
+    putStrLn $ "Final result " ++ show end
+    assert (end == count) $ return ()
diff --git a/testsuite/tests/profiling/should_run/T11978b.stdout b/testsuite/tests/profiling/should_run/T11978b.stdout
new file mode 100644
index 0000000..10976f3
--- /dev/null
+++ b/testsuite/tests/profiling/should_run/T11978b.stdout
@@ -0,0 +1,2 @@
+Start ...
+Final result 50
diff --git a/testsuite/tests/profiling/should_run/all.T b/testsuite/tests/profiling/should_run/all.T
index 1f74a27..8c1ada9 100644
--- a/testsuite/tests/profiling/should_run/all.T
+++ b/testsuite/tests/profiling/should_run/all.T
@@ -110,3 +110,7 @@ test('T11627b', [ extra_run_opts('+RTS -i0 -RTS')  # census after each GC
 test('T11978a',
      [only_ways(['profthreaded']), extra_run_opts('+RTS -hb -N10')],
      compile_and_run, [''])
+
+test('T11978b',
+     [only_ways(['profthrdebug']), extra_run_opts('+RTS -hb -N10')],
+     compile_and_run, [''])



More information about the ghc-commits mailing list