[commit: ghc] wip/erikd/remove-nat: rts: Ensure `overwritingClosure` uses correct closure size (33bea14)
git at git.haskell.org
git at git.haskell.org
Thu May 5 05:19:09 UTC 2016
Repository : ssh://git@git.haskell.org/ghc
On branch : wip/erikd/remove-nat
Link : http://ghc.haskell.org/trac/ghc/changeset/33bea144990bdd5e2846a2aa084f2d645cf18fa1/ghc
>---------------------------------------------------------------
commit 33bea144990bdd5e2846a2aa084f2d645cf18fa1
Author: Erik de Castro Lopo <erikd at mega-nerd.com>
Date: Tue May 3 21:13:17 2016 +1000
rts: Ensure `overwritingClosure` uses correct closure size
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.
>---------------------------------------------------------------
33bea144990bdd5e2846a2aa084f2d645cf18fa1
includes/rts/storage/ClosureMacros.h | 18 +++++++++++++-----
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, 45 insertions(+), 6 deletions(-)
diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h
index d7ae5ea..dc0b557 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,28 +510,34 @@ INLINE_HEADER StgWord8 *mutArrPtrsCard (StgMutArrPtrs *a, W_ n)
void LDV_recordDead (StgClosure *c, uint32_t size);
#endif
-EXTERN_INLINE void overwritingClosure (StgClosure *p);
-EXTERN_INLINE void overwritingClosure (StgClosure *p)
+EXTERN_INLINE void overwritingClosureWithSize (StgClosure *p, uint32_t size);
+EXTERN_INLINE void overwritingClosureWithSize (StgClosure *p, uint32_t size)
{
- uint32_t size, i;
+ uint32_t i;
#if ZERO_SLOP_FOR_LDV_PROF && !ZERO_SLOP_FOR_SANITY_CHECK
// see Note [zeroing slop], also #8402
if (era <= 0) return;
#endif
- size = closure_sizeW(p);
-
// 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)
+{
+ overwritingClosureWithSize(p, closure_sizeW(p));
+}
+
// Version of 'overwritingClosure' which overwrites only a suffix of a
// closure. The offset is expressed in words relative to 'p' and shall
// be less than or equal to closure_sizeW(p), and usually at least as
diff --git a/rts/Messages.h b/rts/Messages.h
index 302cb94..fa7d26f 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