X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FRetainerProfile.c;h=4bfda6fef8eb5ceb0833c5c73483f3b169944c2c;hb=104b00d80891ff1010905df517a9b9c465078c31;hp=b5db15a7b6b346f1eeae58bfef176f7ba32131f3;hpb=5d52d9b64c21dcf77849866584744722f8121389;p=ghc-hetmet.git

diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index b5db15a..4bfda6f 100644
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -366,7 +366,7 @@ find_srt( stackPos *info )
 	bitmap = info->next.srt.srt_bitmap;
 	while (bitmap != 0) {
 	    if ((bitmap & 1) != 0) {
-#if defined(__PIC__) && defined(mingw32_TARGET_OS)
+#if defined(__PIC__) && defined(mingw32_HOST_OS)
 		if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
 		    c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
 		else
@@ -466,8 +466,6 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 	*first_child = ((StgSelector *)c)->selectee;
 	return;
     case IND_PERM:
-    case IND_OLDGEN_PERM:
-    case IND_OLDGEN:
     case BLACKHOLE:
 	*first_child = ((StgInd *)c)->indirectee;
 	return;
@@ -599,11 +597,13 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
     case AP:
     case AP_STACK:
     case TSO:
+    case STACK:
     case IND_STATIC:
     case CONSTR_NOCAF_STATIC:
 	// stack objects
     case UPDATE_FRAME:
     case CATCH_FRAME:
+    case UNDERFLOW_FRAME:
     case STOP_FRAME:
     case RET_DYN:
     case RET_BCO:
@@ -921,21 +921,21 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
 	case MUT_VAR_DIRTY:
 	case THUNK_SELECTOR:
 	case IND_PERM:
-	case IND_OLDGEN_PERM:
-	case IND_OLDGEN:
 	case CONSTR_1_1:
 	    // cannot appear
 	case PAP:
 	case AP:
 	case AP_STACK:
 	case TSO:
-	case IND_STATIC:
+        case STACK:
+        case IND_STATIC:
 	case CONSTR_NOCAF_STATIC:
 	    // stack objects
 	case RET_DYN:
 	case UPDATE_FRAME:
 	case CATCH_FRAME:
-	case STOP_FRAME:
+        case UNDERFLOW_FRAME:
+        case STOP_FRAME:
 	case RET_BCO:
 	case RET_SMALL:
 	case RET_BIG:
@@ -1005,6 +1005,7 @@ isRetainer( StgClosure *c )
 	//
 	// TSOs MUST be retainers: they constitute the set of roots.
     case TSO:
+    case STACK:
 
 	// mutable objects
     case MUT_PRIM:
@@ -1058,8 +1059,10 @@ isRetainer( StgClosure *c )
     case PAP:
 	// indirection
     case IND_PERM:
-    case IND_OLDGEN_PERM:
-    case IND_OLDGEN:
+    // IND_STATIC used to be an error, but at the moment it can happen
+    // as isAlive doesn't look through IND_STATIC as it ignores static
+    // closures. See trac #3956 for a program that hit this error.
+    case IND_STATIC:
     case BLACKHOLE:
 	// static objects
     case CONSTR_STATIC:
@@ -1075,8 +1078,6 @@ isRetainer( StgClosure *c )
 	//
 	// Error case
 	//
-	// IND_STATIC cannot be *c, *cp, *r in the retainer profiling loop.
-    case IND_STATIC:
 	// CONSTR_NOCAF_STATIC
 	// cannot be *c, *cp, *r in the retainer profiling loop.
     case CONSTR_NOCAF_STATIC:
@@ -1084,6 +1085,7 @@ isRetainer( StgClosure *c )
 	// legal objects during retainer profiling.
     case UPDATE_FRAME:
     case CATCH_FRAME:
+    case UNDERFLOW_FRAME:
     case STOP_FRAME:
     case RET_DYN:
     case RET_BCO:
@@ -1233,7 +1235,7 @@ retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
 
   while (bitmap != 0) {
       if ((bitmap & 1) != 0) {
-#if defined(__PIC__) && defined(mingw32_TARGET_OS)
+#if defined(__PIC__) && defined(mingw32_HOST_OS)
 	  if ( (unsigned long)(*srt) & 0x1 ) {
 	      retainClosure(* (StgClosure**) ((unsigned long) (*srt) & ~0x1), 
 			    c, c_child_r);
@@ -1261,8 +1263,8 @@ retainSRT (StgClosure **srt, nat srt_bitmap, StgClosure *c, retainer c_child_r)
  *    RSET(c) and RSET(c_child_r) are valid, i.e., their
  *    interpretation conforms to the current value of flip (even when they
  *    are interpreted to be NULL).
- *    If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete,
- *    or ThreadKilled, which means that its stack is ready to process.
+ *    If *c is TSO, its state is not ThreadComplete,or ThreadKilled, 
+ *    which means that its stack is ready to process.
  *  Note:
  *    This code was almost plagiarzied from GC.c! For each pointer,
  *    retainClosure() is invoked instead of evacuate().
@@ -1274,7 +1276,7 @@ retainStack( StgClosure *c, retainer c_child_r,
     stackElement *oldStackBoundary;
     StgPtr p;
     StgRetInfoTable *info;
-    StgWord32 bitmap;
+    StgWord bitmap;
     nat size;
 
 #ifdef DEBUG_RETAINER
@@ -1295,11 +1297,8 @@ retainStack( StgClosure *c, retainer c_child_r,
     // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary);
 #endif
 
-    ASSERT(get_itbl(c)->type != TSO || 
-	   (((StgTSO *)c)->what_next != ThreadRelocated &&
-	    ((StgTSO *)c)->what_next != ThreadComplete &&
-	    ((StgTSO *)c)->what_next != ThreadKilled));
-    
+    ASSERT(get_itbl(c)->type == STACK);
+
     p = stackStart;
     while (p < stackEnd) {
 	info = get_ret_itbl((StgClosure *)p);
@@ -1311,7 +1310,8 @@ retainStack( StgClosure *c, retainer c_child_r,
 	    p += sizeofW(StgUpdateFrame);
 	    continue;
 
-	case STOP_FRAME:
+        case UNDERFLOW_FRAME:
+        case STOP_FRAME:
 	case CATCH_FRAME:
 	case CATCH_STM_FRAME:
 	case CATCH_RETRY_FRAME:
@@ -1564,14 +1564,7 @@ inner_loop:
 #endif
 	    goto loop;
 	}
-	if (((StgTSO *)c)->what_next == ThreadRelocated) {
-#ifdef DEBUG_RETAINER
-	    debugBelch("ThreadRelocated encountered in retainClosure()\n");
-#endif
-	    c = (StgClosure *)((StgTSO *)c)->_link;
-	    goto inner_loop;
-	}
-	break;
+        break;
 
     case IND_STATIC:
 	// We just skip IND_STATIC, so its retainer set is never computed.
@@ -1685,12 +1678,29 @@ inner_loop:
     // than attempting to save the current position, because doing so
     // would be hard.
     switch (typeOfc) {
-    case TSO:
+    case STACK:
 	retainStack(c, c_child_r,
-		    ((StgTSO *)c)->sp,
-		    ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size);
+                    ((StgStack *)c)->sp,
+                    ((StgStack *)c)->stack + ((StgStack *)c)->stack_size);
 	goto loop;
 
+    case TSO:
+    {
+        StgTSO *tso = (StgTSO *)c;
+
+        retainClosure(tso->stackobj,           c, c_child_r);
+        retainClosure(tso->blocked_exceptions, c, c_child_r);
+        retainClosure(tso->bq,                 c, c_child_r);
+        retainClosure(tso->trec,               c, c_child_r);
+        if (   tso->why_blocked == BlockedOnMVar
+               || tso->why_blocked == BlockedOnBlackHole
+               || tso->why_blocked == BlockedOnMsgThrowTo
+            ) {
+            retainClosure(tso->block_info.closure, c, c_child_r);
+        }
+        goto loop;
+    }
+
     case PAP:
     {
 	StgPAP *pap = (StgPAP *)c;
@@ -1763,7 +1773,7 @@ computeRetainerSet( void )
 {
     StgWeak *weak;
     RetainerSet *rtl;
-    nat g;
+    nat g, n;
     StgPtr ml;
     bdescr *bd;
 #ifdef DEBUG_RETAINER
@@ -1794,7 +1804,8 @@ computeRetainerSet( void )
 	// Traversing through mut_list is necessary
 	// because we can find MUT_VAR objects which have not been
 	// visited during retainer profiling.
-	for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
+        for (n = 0; n < n_capabilities; n++) {
+          for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) {
 	    for (ml = bd->start; ml < bd->free; ml++) {
 
 		maybeInitRetainerSet((StgClosure *)*ml);
@@ -1825,7 +1836,8 @@ computeRetainerSet( void )
 		}
 #endif
 	    }
-	}
+          }
+        }
     }
 }