[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