X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Frts%2FRetainerProfile.c;h=2f93cbf29abe98e7032e92c5d502dc92883ef157;hb=91b07216be1cb09230b7d1b417899ddea8620ff3;hp=e45f8751c1d212de88dbc25c00b1f667da21e93c;hpb=95ca6bff6fc9918203173b442192d9298ef9757a;p=ghc-hetmet.git

diff --git a/ghc/rts/RetainerProfile.c b/ghc/rts/RetainerProfile.c
index e45f875..2f93cbf 100644
--- a/ghc/rts/RetainerProfile.c
+++ b/ghc/rts/RetainerProfile.c
@@ -1,5 +1,4 @@
 /* -----------------------------------------------------------------------------
- * $Id: RetainerProfile.c,v 1.12 2004/09/03 15:28:38 simonmar Exp $
  *
  * (c) The GHC Team, 2001
  * Author: Sungwoo Park
@@ -330,11 +329,11 @@ init_srt_fun( stackPos *info, StgFunInfoTable *infoTable )
 {
     if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
 	info->type = posTypeLargeSRT;
-	info->next.large_srt.srt = (StgLargeSRT *)infoTable->f.srt;
+	info->next.large_srt.srt = (StgLargeSRT *)GET_FUN_SRT(infoTable);
 	info->next.large_srt.offset = 0;
     } else {
 	info->type = posTypeSRT;
-	info->next.srt.srt = (StgClosure **)(infoTable->f.srt);
+	info->next.srt.srt = (StgClosure **)GET_FUN_SRT(infoTable);
 	info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
     }
 }
@@ -344,11 +343,11 @@ init_srt_thunk( stackPos *info, StgThunkInfoTable *infoTable )
 {
     if (infoTable->i.srt_bitmap == (StgHalfWord)(-1)) {
 	info->type = posTypeLargeSRT;
-	info->next.large_srt.srt = (StgLargeSRT *)infoTable->srt;
+	info->next.large_srt.srt = (StgLargeSRT *)GET_SRT(infoTable);
 	info->next.large_srt.offset = 0;
     } else {
 	info->type = posTypeSRT;
-	info->next.srt.srt = (StgClosure **)(infoTable->srt);
+	info->next.srt.srt = (StgClosure **)GET_SRT(infoTable);
 	info->next.srt.srt_bitmap = infoTable->i.srt_bitmap;
     }
 }
@@ -464,22 +463,17 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 	return;
 
 	// one child (fixed), no SRT
-    case MUT_VAR:
-    case MUT_CONS:
+    case MUT_VAR_CLEAN:
+    case MUT_VAR_DIRTY:
 	*first_child = ((StgMutVar *)c)->var;
 	return;
-    case BLACKHOLE_BQ:
-	// blocking_queue must be TSO and the head of a linked list of TSOs.
-	// Shoule it be a child? Seems to be yes.
-	*first_child = (StgClosure *)((StgBlockingQueue *)c)->blocking_queue;
-	return;
     case THUNK_SELECTOR:
 	*first_child = ((StgSelector *)c)->selectee;
 	return;
     case IND_PERM:
     case IND_OLDGEN_PERM:
     case IND_OLDGEN:
-	*first_child = ((StgIndOldGen *)c)->indirectee;
+	*first_child = ((StgInd *)c)->indirectee;
 	return;
     case CONSTR_1_0:
     case CONSTR_1_1:
@@ -517,7 +511,6 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 
 	// layout.payload.ptrs, no SRT
     case CONSTR:
-    case FOREIGN:
     case STABLE_NAME:
     case BCO:
     case CONSTR_STATIC:
@@ -529,8 +522,10 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 	break;
 
 	// StgMutArrPtr.ptrs, no SRT
-    case MUT_ARR_PTRS:
+    case MUT_ARR_PTRS_CLEAN:
+    case MUT_ARR_PTRS_DIRTY:
     case MUT_ARR_PTRS_FROZEN:
+    case MUT_ARR_PTRS_FROZEN0:
 	init_ptrs(&se.info, ((StgMutArrPtrs *)c)->ptrs,
 		  (StgPtr)(((StgMutArrPtrs *)c)->payload));
 	*first_child = find_ptrs(&se.info);
@@ -550,7 +545,8 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 
     case THUNK:
     case THUNK_2_0:
-	init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, (StgPtr)c->payload);
+	init_ptrs(&se.info, get_itbl(c)->layout.payload.ptrs, 
+		  (StgPtr)((StgThunk *)c)->payload);
 	*first_child = find_ptrs(&se.info);
 	if (*first_child == NULL)
 	    // no child from ptrs, so check SRT
@@ -567,7 +563,7 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
 
     case THUNK_1_0:
     case THUNK_1_1:
-	*first_child = c->payload[0];
+	*first_child = ((StgThunk *)c)->payload[0];
 	ASSERT(*first_child != NULL);
 	init_srt_thunk(&se.info, get_thunk_itbl(c));
 	break;
@@ -822,13 +818,14 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
 	    return;
 
 	case CONSTR:
-	case FOREIGN:
 	case STABLE_NAME:
 	case BCO:
 	case CONSTR_STATIC:
 	    // StgMutArrPtr.ptrs, no SRT
-	case MUT_ARR_PTRS:
+	case MUT_ARR_PTRS_CLEAN:
+	case MUT_ARR_PTRS_DIRTY:
 	case MUT_ARR_PTRS_FROZEN:
+	case MUT_ARR_PTRS_FROZEN0:
 	    *c = find_ptrs(&se->info);
 	    if (*c == NULL) {
 		popOff();
@@ -895,9 +892,8 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
 	case SE_CAF_BLACKHOLE:
 	case ARR_WORDS:
 	    // one child (fixed), no SRT
-	case MUT_VAR:
-	case MUT_CONS:
-	case BLACKHOLE_BQ:
+	case MUT_VAR_CLEAN:
+	case MUT_VAR_DIRTY:
 	case THUNK_SELECTOR:
 	case IND_PERM:
 	case IND_OLDGEN_PERM:
@@ -997,10 +993,12 @@ isRetainer( StgClosure *c )
 
 	// mutable objects
     case MVAR:
-    case MUT_VAR:
-    case MUT_CONS:
-    case MUT_ARR_PTRS:
+    case MUT_VAR_CLEAN:
+    case MUT_VAR_DIRTY:
+    case MUT_ARR_PTRS_CLEAN:
+    case MUT_ARR_PTRS_DIRTY:
     case MUT_ARR_PTRS_FROZEN:
+    case MUT_ARR_PTRS_FROZEN0:
 
 	// thunks are retainers.
     case THUNK:
@@ -1046,7 +1044,6 @@ isRetainer( StgClosure *c )
     case BLACKHOLE:
     case SE_BLACKHOLE:
     case SE_CAF_BLACKHOLE:
-    case BLACKHOLE_BQ:
 	// indirection
     case IND_PERM:
     case IND_OLDGEN_PERM:
@@ -1055,7 +1052,6 @@ isRetainer( StgClosure *c )
     case CONSTR_STATIC:
     case FUN_STATIC:
 	// misc
-    case FOREIGN:
     case STABLE_NAME:
     case BCO:
     case ARR_WORDS:
@@ -1320,7 +1316,7 @@ retainStack( StgClosure *c, retainer c_child_r,
 	    p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
 
 	follow_srt:
-	    retainSRT((StgClosure **)info->srt, info->i.srt_bitmap, c, c_child_r);
+	    retainSRT((StgClosure **)GET_SRT(info), info->i.srt_bitmap, c, c_child_r);
 	    continue;
 
 	case RET_BCO: {
@@ -1339,9 +1335,9 @@ retainStack( StgClosure *c, retainer c_child_r,
 	    // large bitmap (> 32 entries, or > 64 on a 64-bit machine) 
 	case RET_BIG:
 	case RET_VEC_BIG:
-	    size = info->i.layout.large_bitmap->size;
+	    size = GET_LARGE_BITMAP(&info->i)->size;
 	    p++;
-	    retain_large_bitmap(p, info->i.layout.large_bitmap,
+	    retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
 				size, c, c_child_r);
 	    p += size;
 	    // and don't forget to follow the SRT 
@@ -1379,13 +1375,13 @@ retainStack( StgClosure *c, retainer c_child_r,
 	    p = (P_)&ret_fun->payload;
 	    switch (fun_info->f.fun_type) {
 	    case ARG_GEN:
-		bitmap = BITMAP_BITS(fun_info->f.bitmap);
-		size = BITMAP_SIZE(fun_info->f.bitmap);
+		bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
+		size = BITMAP_SIZE(fun_info->f.b.bitmap);
 		p = retain_small_bitmap(p, size, bitmap, c, c_child_r);
 		break;
 	    case ARG_GEN_BIG:
-		size = ((StgLargeBitmap *)fun_info->f.bitmap)->size;
-		retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap, 
+		size = GET_FUN_LARGE_BITMAP(fun_info)->size;
+		retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info), 
 				    size, c, c_child_r);
 		p += size;
 		break;
@@ -1420,39 +1416,38 @@ retainStack( StgClosure *c, retainer c_child_r,
  * ------------------------------------------------------------------------- */
 
 static INLINE StgPtr
-retain_PAP (StgPAP *pap, retainer c_child_r)
+retain_PAP_payload (StgClosure *pap,  retainer c_child_r, StgClosure *fun, 
+		    StgClosure** payload, StgWord n_args)
 {
     StgPtr p;
-    StgWord bitmap, size;
+    StgWord bitmap;
     StgFunInfoTable *fun_info;
 
-    retainClosure(pap->fun, (StgClosure *)pap, c_child_r);
-    fun_info = get_fun_itbl(pap->fun);
+    retainClosure(fun, pap, c_child_r);
+    fun_info = get_fun_itbl(fun);
     ASSERT(fun_info->i.type != PAP);
 
-    p = (StgPtr)pap->payload;
-    size = pap->n_args;
+    p = (StgPtr)payload;
 
     switch (fun_info->f.fun_type) {
     case ARG_GEN:
-	bitmap = BITMAP_BITS(fun_info->f.bitmap);
-	p = retain_small_bitmap(p, pap->n_args, bitmap, 
-				(StgClosure *)pap, c_child_r);
+	bitmap = BITMAP_BITS(fun_info->f.b.bitmap);
+	p = retain_small_bitmap(p, n_args, bitmap, 
+				pap, c_child_r);
 	break;
     case ARG_GEN_BIG:
-	retain_large_bitmap(p, (StgLargeBitmap *)fun_info->f.bitmap,
-			    size, (StgClosure *)pap, c_child_r);
-	p += size;
+	retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
+			    n_args, pap, c_child_r);
+	p += n_args;
 	break;
     case ARG_BCO:
-	retain_large_bitmap((StgPtr)pap->payload, BCO_BITMAP(pap->fun),
-			    size, (StgClosure *)pap, c_child_r);
-	p += size;
+	retain_large_bitmap((StgPtr)payload, BCO_BITMAP(fun),
+			    n_args, pap, c_child_r);
+	p += n_args;
 	break;
     default:
 	bitmap = BITMAP_BITS(stg_arg_bitmaps[fun_info->f.fun_type]);
-	p = retain_small_bitmap(p, pap->n_args, bitmap, 
-				(StgClosure *)pap, c_child_r);
+	p = retain_small_bitmap(p, n_args, bitmap, pap, c_child_r);
 	break;
     }
     return p;
@@ -1690,9 +1685,18 @@ inner_loop:
 	goto loop;
 
     case PAP:
+    {
+	StgPAP *pap = (StgPAP *)c;
+	retain_PAP_payload(c, c_child_r, pap->fun, pap->payload, pap->n_args);
+	goto loop;
+    }
+
     case AP:
-	retain_PAP((StgPAP *)c, c_child_r);
+    {
+	StgAP *ap = (StgAP *)c;
+	retain_PAP_payload(c, c_child_r, ap->fun, ap->payload, ap->n_args);
 	goto loop;
+    }
 
     case AP_STACK:
 	retainClosure(((StgAP_STACK *)c)->fun, c, c_child_r);
@@ -1750,7 +1754,8 @@ computeRetainerSet( void )
     StgWeak *weak;
     RetainerSet *rtl;
     nat g;
-    StgMutClosure *ml;
+    StgPtr ml;
+    bdescr *bd;
 #ifdef DEBUG_RETAINER
     RetainerSet tmpRetainerSet;
 #endif
@@ -1773,81 +1778,44 @@ computeRetainerSet( void )
     // object (computing sumOfNewCostExtra and updating costArray[] when
     // debugging retainer profiler).
     for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
-	ASSERT(g != 0 ||
-	       (generations[g].mut_list == END_MUT_LIST &&
-		generations[g].mut_once_list == END_MUT_LIST));
+        ASSERT(g != 0 || (generations[g].mut_list == NULL));
 
-	// Todo:
-	// I think traversing through mut_list is unnecessary.
-	// Think about removing this part.
-	for (ml = generations[g].mut_list; ml != END_MUT_LIST;
-	     ml = ml->mut_link) {
-
-	    maybeInitRetainerSet((StgClosure *)ml);
-	    rtl = retainerSetOf((StgClosure *)ml);
-
-#ifdef DEBUG_RETAINER
-	    if (rtl == NULL) {
-		// first visit to *ml
-		// This is a violation of the interface rule!
-		RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
-
-		switch (get_itbl((StgClosure *)ml)->type) {
-		case IND_STATIC:
-		    // no cost involved
-		    break;
-		case CONSTR_INTLIKE:
-		case CONSTR_CHARLIKE:
-		case CONSTR_NOCAF_STATIC:
-		case CONSTR_STATIC:
-		case THUNK_STATIC:
-		case FUN_STATIC:
-		    barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
-		    break;
-		default:
-		    // dynamic objects
-		    costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
-		    sumOfNewCostExtra += cost((StgClosure *)ml);
-		    break;
-		}
-	    }
-#endif
-	}
-
-	// Traversing through mut_once_list is, in contrast, necessary
+	// Traversing through mut_list is necessary
 	// because we can find MUT_VAR objects which have not been
 	// visited during retainer profiling.
-	for (ml = generations[g].mut_once_list; ml != END_MUT_LIST;
-	     ml = ml->mut_link) {
+	for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
+	    for (ml = bd->start; ml < bd->free; ml++) {
+
+		maybeInitRetainerSet((StgClosure *)*ml);
+		rtl = retainerSetOf((StgClosure *)*ml);
 
-	    maybeInitRetainerSet((StgClosure *)ml);
-	    rtl = retainerSetOf((StgClosure *)ml);
 #ifdef DEBUG_RETAINER
-	    if (rtl == NULL) {
-		// first visit to *ml
-		// This is a violation of the interface rule!
-		RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
-
-		switch (get_itbl((StgClosure *)ml)->type) {
-		case IND_STATIC:
-		    // no cost involved
-		    break;
-		case CONSTR_INTLIKE:
-		case CONSTR_CHARLIKE:
-		case CONSTR_NOCAF_STATIC:
-		case CONSTR_STATIC:
-		case THUNK_STATIC:
-		case FUN_STATIC:
-		    barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
-		    break;
-		default:
-		    // dynamic objects
-		    costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
-		    sumOfNewCostExtra += cost((StgClosure *)ml);
-		    break;
+		if (rtl == NULL) {
+		    // first visit to *ml
+		    // This is a violation of the interface rule!
+		    RSET(ml) = (RetainerSet *)((StgWord)(&tmpRetainerSet) | flip);
+		    
+		    switch (get_itbl((StgClosure *)ml)->type) {
+		    case IND_STATIC:
+			// no cost involved
+			break;
+		    case CONSTR_INTLIKE:
+		    case CONSTR_CHARLIKE:
+		    case CONSTR_NOCAF_STATIC:
+		    case CONSTR_STATIC:
+		    case THUNK_STATIC:
+		    case FUN_STATIC:
+			barf("Invalid object in computeRetainerSet(): %d", get_itbl((StgClosure*)ml)->type);
+			break;
+		    default:
+			// dynamic objects
+			costArray[get_itbl((StgClosure *)ml)->type] += cost((StgClosure *)ml);
+			sumOfNewCostExtra += cost((StgClosure *)ml);
+			break;
+		    }
 		}
-	    }
 #endif
+	    }
 	}
     }
 }
@@ -1889,19 +1857,19 @@ resetStaticObjectForRetainerProfiling( void )
 	    // Since we do not compute the retainer set of any
 	    // IND_STATIC object, we don't have to reset its retainer
 	    // field.
-	    p = IND_STATIC_LINK(p);
+	    p = (StgClosure*)*IND_STATIC_LINK(p);
 	    break;
 	case THUNK_STATIC:
 	    maybeInitRetainerSet(p);
-	    p = THUNK_STATIC_LINK(p);
+	    p = (StgClosure*)*THUNK_STATIC_LINK(p);
 	    break;
 	case FUN_STATIC:
 	    maybeInitRetainerSet(p);
-	    p = FUN_STATIC_LINK(p);
+	    p = (StgClosure*)*FUN_STATIC_LINK(p);
 	    break;
 	case CONSTR_STATIC:
 	    maybeInitRetainerSet(p);
-	    p = STATIC_LINK(get_itbl(p), p);
+	    p = (StgClosure*)*STATIC_LINK(get_itbl(p), p);
 	    break;
 	default:
 	    barf("resetStaticObjectForRetainerProfiling: %p (%s)",
@@ -2065,7 +2033,7 @@ retainerProfile(void)
 #ifdef DEBUG_RETAINER
 
 #define LOOKS_LIKE_PTR(r) ((LOOKS_LIKE_STATIC_CLOSURE(r) || \
-        ((HEAP_ALLOCED(r) && Bdescr((P_)r)->free != (void *)-1))) && \
+        ((HEAP_ALLOCED(r) && ((Bdescr((P_)r)->flags & BF_FREE) == 0)))) && \
         ((StgWord)(*(StgPtr)r)!=0xaaaaaaaa))
 
 static nat
@@ -2110,8 +2078,10 @@ sanityCheckHeapClosure( StgClosure *c )
     case MVAR:
 	return sizeofW(StgMVar);
 
-    case MUT_ARR_PTRS:
+    case MUT_ARR_PTRS_CLEAN:
+    case MUT_ARR_PTRS_DIRTY:
     case MUT_ARR_PTRS_FROZEN:
+    case MUT_ARR_PTRS_FROZEN0:
 	return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
 
     case AP:
@@ -2137,17 +2107,15 @@ sanityCheckHeapClosure( StgClosure *c )
     case FUN_1_1:
     case FUN_0_2:
     case WEAK:
-    case MUT_VAR:
-    case MUT_CONS:
+    case MUT_VAR_CLEAN:
+    case MUT_VAR_DIRTY:
     case CAF_BLACKHOLE:
     case BLACKHOLE:
     case SE_BLACKHOLE:
     case SE_CAF_BLACKHOLE:
-    case BLACKHOLE_BQ:
     case IND_PERM:
     case IND_OLDGEN:
     case IND_OLDGEN_PERM:
-    case FOREIGN:
     case BCO:
     case STABLE_NAME:
 	return sizeW_fromITBL(info);
@@ -2376,6 +2344,6 @@ belongToHeap(StgPtr p)
 	}
     }
 }
-#endif // DEBUG_RETAINER
+#endif /* DEBUG_RETAINER */
 
 #endif /* PROFILING */