support for STM objects in the retainer profiler
[ghc-hetmet.git] / ghc / rts / RetainerProfile.c
index 074c256..c5c3de5 100644 (file)
@@ -463,7 +463,8 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
        return;
 
        // one child (fixed), no SRT
-    case MUT_VAR:
+    case MUT_VAR_CLEAN:
+    case MUT_VAR_DIRTY:
        *first_child = ((StgMutVar *)c)->var;
        return;
     case THUNK_SELECTOR:
@@ -521,7 +522,8 @@ 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,
@@ -588,6 +590,21 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
        if (*first_child == NULL)
            return;     // no child
        break;
+       
+    case TVAR_WAIT_QUEUE:
+       *first_child = (StgClosure *)((StgTVarWaitQueue *)c)->waiting_tso;
+       se.info.next.step = 2;            // 2 = second
+       break;
+    case TVAR:
+       *first_child = (StgClosure *)((StgTVar *)c)->current_value;
+       break;
+    case TREC_HEADER:
+       *first_child = (StgClosure *)((StgTRecHeader *)c)->enclosing_trec;
+       break;
+    case TREC_CHUNK:
+       *first_child = (StgClosure *)((StgTRecChunk *)c)->prev_chunk;
+       se.info.next.step = 0;  // entry no.
+       break;
 
        // cannot appear
     case PAP:
@@ -815,12 +832,67 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
            *r = se->c_child_r;
            return;
 
+       case TVAR_WAIT_QUEUE:
+           if (se->info.next.step == 2) {
+               *c = (StgClosure *)((StgTVarWaitQueue *)se->c)->next_queue_entry;
+               se->info.next.step++;             // move to the next step
+               // no popOff
+           } else {
+               *c = (StgClosure *)((StgTVarWaitQueue *)se->c)->prev_queue_entry;
+               popOff();
+           }
+           *cp = se->c;
+           *r = se->c_child_r;
+           return;
+
+       case TVAR:
+           *c = (StgClosure *)((StgTVar *)se->c)->first_wait_queue_entry;
+           *cp = se->c;
+           *r = se->c_child_r;
+           popOff();
+           return;
+
+       case TREC_HEADER:
+           *c = (StgClosure *)((StgTRecHeader *)se->c)->current_chunk;
+           *cp = se->c;
+           *r = se->c_child_r;
+           popOff();
+           return;
+
+       case TREC_CHUNK: {
+           // These are pretty complicated: we have N entries, each
+           // of which contains 3 fields that we want to follow.  So
+           // we divide the step counter: the 2 low bits indicate
+           // which field, and the rest of the bits indicate the
+           // entry number (starting from zero).
+           nat entry_no = se->info.next.step >> 2;
+           nat field_no = se->info.next.step & 3;
+           if (entry_no == ((StgTRecChunk *)se->c)->next_entry_idx) {
+               *c = NULL;
+               popOff();
+               return;
+           }
+           TRecEntry *entry = &((StgTRecChunk *)se->c)->entries[entry_no];
+           if (field_no == 0) {
+               *c = (StgClosure *)entry->tvar;
+           } else if (field_no == 1) {
+               *c = entry->expected_value;
+           } else {
+               *c = entry->new_value;
+           }
+           *cp = se->c;
+           *r = se->c_child_r;
+           se->info.next.step++;
+           return;
+       }
+
        case CONSTR:
        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);
@@ -889,7 +961,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_VAR_CLEAN:
+       case MUT_VAR_DIRTY:
        case THUNK_SELECTOR:
        case IND_PERM:
        case IND_OLDGEN_PERM:
@@ -989,8 +1062,10 @@ isRetainer( StgClosure *c )
 
        // mutable objects
     case MVAR:
-    case MUT_VAR:
-    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:
 
@@ -1011,6 +1086,10 @@ isRetainer( StgClosure *c )
        // WEAK objects are roots; there is separate code in which traversing
        // begins from WEAK objects.
     case WEAK:
+
+       // Since the other mutvar-type things are retainers, seems
+       // like the right thing to do:
+    case TVAR:
        return rtsTrue;
 
        //
@@ -1049,6 +1128,10 @@ isRetainer( StgClosure *c )
     case STABLE_NAME:
     case BCO:
     case ARR_WORDS:
+       // STM
+    case TVAR_WAIT_QUEUE:
+    case TREC_HEADER:
+    case TREC_CHUNK:
        return rtsFalse;
 
        //
@@ -1302,6 +1385,9 @@ retainStack( StgClosure *c, retainer c_child_r,
 
        case STOP_FRAME:
        case CATCH_FRAME:
+       case CATCH_STM_FRAME:
+       case CATCH_RETRY_FRAME:
+       case ATOMICALLY_FRAME:
        case RET_SMALL:
        case RET_VEC_SMALL:
            bitmap = BITMAP_BITS(info->i.layout.bitmap);
@@ -1728,7 +1814,7 @@ retainRoot( StgClosure **tl )
     ASSERT(isEmptyRetainerStack());
     currentStackBoundary = stackTop;
 
-    if (isRetainer(*tl)) {
+    if (*tl != &stg_END_TSO_QUEUE_closure && isRetainer(*tl)) {
        retainClosure(*tl, *tl, getRetainerFrom(*tl));
     } else {
        retainClosure(*tl, *tl, CCS_SYSTEM);
@@ -1772,7 +1858,8 @@ 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 == NULL));
+       // NOT TRUE: even G0 has a block on its mutable list
+        // ASSERT(g != 0 || (generations[g].mut_list == NULL));
 
        // Traversing through mut_list is necessary
        // because we can find MUT_VAR objects which have not been
@@ -2056,97 +2143,7 @@ sanityCheckHeapClosure( StgClosure *c )
        // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));
     }
 
-    info = get_itbl(c);
-    switch (info->type) {
-    case TSO:
-       return tso_sizeW((StgTSO *)c);
-
-    case THUNK:
-    case THUNK_1_0:
-    case THUNK_0_1:
-    case THUNK_2_0:
-    case THUNK_1_1:
-    case THUNK_0_2:
-       return stg_max(sizeW_fromITBL(info), sizeofW(StgHeader) + MIN_UPD_SIZE);
-
-    case MVAR:
-       return sizeofW(StgMVar);
-
-    case MUT_ARR_PTRS:
-    case MUT_ARR_PTRS_FROZEN:
-    case MUT_ARR_PTRS_FROZEN0:
-       return mut_arr_ptrs_sizeW((StgMutArrPtrs *)c);
-
-    case AP:
-    case PAP:
-       return pap_sizeW((StgPAP *)c);
-
-    case AP:
-       return ap_stack_sizeW((StgAP_STACK *)c);
-
-    case ARR_WORDS:
-       return arr_words_sizeW((StgArrWords *)c);
-
-    case CONSTR:
-    case CONSTR_1_0:
-    case CONSTR_0_1:
-    case CONSTR_2_0:
-    case CONSTR_1_1:
-    case CONSTR_0_2:
-    case FUN:
-    case FUN_1_0:
-    case FUN_0_1:
-    case FUN_2_0:
-    case FUN_1_1:
-    case FUN_0_2:
-    case WEAK:
-    case MUT_VAR:
-    case CAF_BLACKHOLE:
-    case BLACKHOLE:
-    case SE_BLACKHOLE:
-    case SE_CAF_BLACKHOLE:
-    case IND_PERM:
-    case IND_OLDGEN:
-    case IND_OLDGEN_PERM:
-    case BCO:
-    case STABLE_NAME:
-       return sizeW_fromITBL(info);
-
-    case THUNK_SELECTOR:
-       return sizeofW(StgHeader) + MIN_UPD_SIZE;
-
-       /*
-         Error case
-       */
-    case IND_STATIC:
-    case CONSTR_STATIC:
-    case FUN_STATIC:
-    case THUNK_STATIC:
-    case CONSTR_INTLIKE:
-    case CONSTR_CHARLIKE:
-    case CONSTR_NOCAF_STATIC:
-    case UPDATE_FRAME:
-    case CATCH_FRAME:
-    case STOP_FRAME:
-    case RET_DYN:
-    case RET_BCO:
-    case RET_SMALL:
-    case RET_VEC_SMALL:
-    case RET_BIG:
-    case RET_VEC_BIG:
-    case IND:
-    case BLOCKED_FETCH:
-    case FETCH_ME:
-    case FETCH_ME_BQ:
-    case RBH:
-    case REMOTE_REF:
-    case EVACUATED:
-    case INVALID_OBJECT:
-    default:
-       barf("Invalid object in sanityCheckHeapClosure(): %d",
-            get_itbl(c)->type);
-       return 0;
-    }
+    return closure_sizeW(c);
 }
 
 static nat