when a memory leak is detected, report which blocks are unreachable

[ghc-hetmet.git] / rts / sm / Storage.c

diff --git a/rts/sm/Storage.c b/rts/sm/Storage.c
index 69e441d..a6134c6 100644 (file)
--- a/rts/sm/Storage.c
+++ b/rts/sm/Storage.c
@@ -124,7 +124,7 @@ initStorage( void )
    * doing something reasonable.
    */
   /* We use the NOT_NULL variant or gcc warns that the test is always true */
-  ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL(&stg_BLACKHOLE_info));
+  ASSERT(LOOKS_LIKE_INFO_PTR_NOT_NULL((StgWord)&stg_BLACKHOLE_info));
   ASSERT(LOOKS_LIKE_CLOSURE_PTR(&stg_dummy_ret_closure));
   ASSERT(!HEAP_ALLOCED(&stg_dummy_ret_closure));
   
@@ -585,7 +585,7 @@ move_TSO (StgTSO *src, StgTSO *dest)
    -------------------------------------------------------------------------- */
 
 StgPtr
-allocateInGen (generation *g, nat n)
+allocateInGen (generation *g, lnat n)
 {
     step *stp;
     bdescr *bd;
@@ -600,7 +600,7 @@ allocateInGen (generation *g, nat n)
 
     if (n >= LARGE_OBJECT_THRESHOLD/sizeof(W_))
     {
-       nat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
+       lnat req_blocks =  (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
 
         // Attempting to allocate an object larger than maxHeapSize
         // should definitely be disallowed.  (bug #1791)
@@ -642,7 +642,7 @@ allocateInGen (generation *g, nat n)
 }
 
 StgPtr
-allocate (nat n)
+allocate (lnat n)
 {
     return allocateInGen(g0,n);
 }
@@ -703,7 +703,7 @@ splitLargeBlock (bdescr *bd, nat blocks)
    -------------------------------------------------------------------------- */
 
 StgPtr
-allocateLocal (Capability *cap, nat n)
+allocateLocal (Capability *cap, lnat n)
 {
     bdescr *bd;
     StgPtr p;
@@ -780,7 +780,7 @@ allocateLocal (Capability *cap, nat n)
    ------------------------------------------------------------------------- */
 
 StgPtr
-allocatePinned( nat n )
+allocatePinned( lnat n )
 {
     StgPtr p;
     bdescr *bd = pinned_object_block;
@@ -1270,6 +1270,51 @@ stepBlocks (step *stp)
            countAllocdBlocks(stp->large_objects);
 }
 
+// If memInventory() calculates that we have a memory leak, this
+// function will try to find the block(s) that are leaking by marking
+// all the ones that we know about, and search through memory to find
+// blocks that are not marked.  In the debugger this can help to give
+// us a clue about what kind of block leaked.  In the future we might
+// annotate blocks with their allocation site to give more helpful
+// info.
+static void
+findMemoryLeak (void)
+{
+  nat g, s, i;
+  for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+      for (i = 0; i < n_capabilities; i++) {
+         markBlocks(capabilities[i].mut_lists[g]);
+      }
+      markBlocks(generations[g].mut_list);
+      for (s = 0; s < generations[g].n_steps; s++) {
+         markBlocks(generations[g].steps[s].blocks);
+         markBlocks(generations[g].steps[s].large_objects);
+      }
+  }
+
+  for (i = 0; i < n_nurseries; i++) {
+      markBlocks(nurseries[i].blocks);
+      markBlocks(nurseries[i].large_objects);
+  }
+
+#ifdef PROFILING
+  // TODO:
+  // if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
+  //    markRetainerBlocks();
+  // }
+#endif
+
+  // count the blocks allocated by the arena allocator
+  // TODO:
+  // markArenaBlocks();
+
+  // count the blocks containing executable memory
+  markBlocks(exec_block);
+
+  reportUnmarkedBlocks();
+}
+
+
 void
 memInventory (rtsBool show)
 {
@@ -1327,8 +1372,6 @@ memInventory (rtsBool show)
 
   leak = live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK;
 
-  ASSERT(n_alloc_blocks == live_blocks);
-
   if (show || leak)
   {
       if (leak) { 
@@ -1357,6 +1400,13 @@ memInventory (rtsBool show)
                      mblocks_allocated * BLOCKS_PER_MBLOCK, mblocks_allocated);
       }
   }
+
+  if (leak) {
+      debugBelch("\n");
+      findMemoryLeak();
+  }
+  ASSERT(n_alloc_blocks == live_blocks);
+  ASSERT(!leak);
 }
 
 
@@ -1395,6 +1445,14 @@ checkSanity( void )
            
        checkFreeListSanity();
     }
+
+#if defined(THREADED_RTS)
+    // check the stacks too in threaded mode, because we don't do a
+    // full heap sanity check in this case (see checkHeap())
+    checkGlobalTSOList(rtsTrue);
+#else
+    checkGlobalTSOList(rtsFalse);
+#endif
 }
 
 /* Nursery sanity check */