diff options
| -rw-r--r-- | includes/rts/storage/ClosureMacros.h | 26 | ||||
| -rw-r--r-- | rts/Messages.h | 2 | ||||
| -rw-r--r-- | testsuite/config/ghc | 3 | ||||
| -rw-r--r-- | testsuite/tests/profiling/should_run/T11978b.hs | 22 | ||||
| -rw-r--r-- | testsuite/tests/profiling/should_run/T11978b.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/profiling/should_run/all.T | 4 |
6 files changed, 58 insertions, 1 deletions
diff --git a/includes/rts/storage/ClosureMacros.h b/includes/rts/storage/ClosureMacros.h index 03589f2f16..4f38c76da6 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 4121364b21..69319c25e8 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 595415ae7b..347b8b197a 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 0000000000..226e7d1687 --- /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 0000000000..10976f3e80 --- /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 1f74a27c8f..8c1ada9c18 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, ['']) |