[commit: ghc] wip/ghc-8.6-merge: Implement a sanity check for CCS fields in profiling builds (4f712fb)

[git at git.haskell.org]

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

On branch  : wip/ghc-8.6-merge
Link       : http://ghc.haskell.org/trac/ghc/changeset/4f712fb3c88d2586f842202ca3dd921596599777/ghc

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

commit 4f712fb3c88d2586f842202ca3dd921596599777
Author: Ömer Sinan Ağacan <omeragacan at gmail.com>
Date:   Thu Jan 10 12:42:04 2019 +0300

    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.
    
    (cherry picked from commit 82d1a88dec216d761b17252ede760da5c566007f)


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

4f712fb3c88d2586f842202ca3dd921596599777
 rts/Arena.c     | 13 +++++++++++++
 rts/Arena.h     |  4 ++++
 rts/Profiling.c |  4 ++++
 rts/Profiling.h |  6 ++++++
 rts/sm/Sanity.c | 17 +++++++++++++++++
 5 files changed, 44 insertions(+)

diff --git a/rts/Arena.c b/rts/Arena.c
index cd547e5..e0b4ebd 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 8fa8236..4929871 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 9f1a442..162651d 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 45725e5..c692c22 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 c6861f4..748f2f4 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) {