diff options
author | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2019-01-10 12:42:04 +0300 |
---|---|---|
committer | Ömer Sinan Ağacan <omeragacan@gmail.com> | 2019-01-10 12:42:04 +0300 |
commit | 82d1a88dec216d761b17252ede760da5c566007f (patch) | |
tree | f925f9294d73682ffccda2ea77374a8ceb685c8e | |
parent | 6486c6e49c53e75f37ed732b38c5be7ae64785e8 (diff) | |
download | haskell-82d1a88dec216d761b17252ede760da5c566007f.tar.gz |
Implement a sanity check for CCS fields in profiling builds
This helped me debug one of the bugs in #15508. I'm not sure if this is
a good idea, but it worked for me, so wanted to submit this as a MR.
-rw-r--r-- | rts/Arena.c | 13 | ||||
-rw-r--r-- | rts/Arena.h | 4 | ||||
-rw-r--r-- | rts/Profiling.c | 4 | ||||
-rw-r--r-- | rts/Profiling.h | 6 | ||||
-rw-r--r-- | rts/sm/Sanity.c | 17 |
5 files changed, 44 insertions, 0 deletions
diff --git a/rts/Arena.c b/rts/Arena.c index cd547e5b33..e0b4ebde30 100644 --- a/rts/Arena.c +++ b/rts/Arena.c @@ -117,3 +117,16 @@ arenaBlocks( void ) { return arena_blocks; } + +#if defined(DEBUG) +void checkPtrInArena( StgPtr p, Arena *arena ) +{ + for (bdescr *bd = arena->current; bd; bd = bd->link) { + if (p >= bd->start && p < bd->free) { + return; + } + } + + barf("Location %p is not in arena %p", (void*)p, (void*)arena); +} +#endif diff --git a/rts/Arena.h b/rts/Arena.h index 8fa8236d8d..49298713ab 100644 --- a/rts/Arena.h +++ b/rts/Arena.h @@ -20,3 +20,7 @@ RTS_PRIVATE void arenaFree ( Arena * ); // For internal use only: RTS_PRIVATE unsigned long arenaBlocks( void ); + +#if defined(DEBUG) +void checkPtrInArena( StgPtr p, Arena *arena ); +#endif diff --git a/rts/Profiling.c b/rts/Profiling.c index 7abad59b1f..70bf3750e3 100644 --- a/rts/Profiling.c +++ b/rts/Profiling.c @@ -32,7 +32,11 @@ /* * Profiling allocation arena. */ +#if defined(DEBUG) +Arena *prof_arena; +#else static Arena *prof_arena; +#endif /* * Global variables used to assign unique IDs to cc's, ccs's, and diff --git a/rts/Profiling.h b/rts/Profiling.h index 45725e5631..c692c22b5e 100644 --- a/rts/Profiling.h +++ b/rts/Profiling.h @@ -13,6 +13,10 @@ #include "BeginPrivate.h" #include "Rts.h" +#if defined(DEBUG) +#include "Arena.h" +#endif + #if defined(PROFILING) #define PROFILING_ONLY(s) s #else @@ -46,6 +50,8 @@ bool ignoreCCS (CostCentreStack const *ccs); bool ignoreCC (CostCentre const *cc); #if defined(DEBUG) +extern Arena *prof_arena; + void debugCCS( CostCentreStack *ccs ); #endif diff --git a/rts/sm/Sanity.c b/rts/sm/Sanity.c index 1da3e4416f..28c9b432f8 100644 --- a/rts/sm/Sanity.c +++ b/rts/sm/Sanity.c @@ -29,6 +29,7 @@ #include "Arena.h" #include "RetainerProfile.h" #include "CNF.h" +#include "Profiling.h" // prof_arena /* ----------------------------------------------------------------------------- Forward decls. @@ -210,6 +211,17 @@ checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args) : GET_CLOSURE_TAG(tagged_fun) == fun_info->f.arity); } +#if defined(PROFILING) +static void +checkClosureProfSanity(const StgClosure *p) +{ + StgProfHeader prof_hdr = p->header.prof; + CostCentreStack *ccs = prof_hdr.ccs; + if (HEAP_ALLOCED_GC((void*)ccs)) { + checkPtrInArena((StgPtr)ccs, prof_arena); + } +} +#endif StgOffset checkClosure( const StgClosure* p ) @@ -225,6 +237,11 @@ checkClosure( const StgClosure* p ) if (IS_FORWARDING_PTR(info)) { barf("checkClosure: found EVACUATED closure %d", info->type); } + +#if defined(PROFILING) + checkClosureProfSanity(p); +#endif + info = INFO_PTR_TO_STRUCT(info); switch (info->type) { |