make the smp way RTS-only, normal libraries now work with -smp
[ghc-hetmet.git] / ghc / rts / RetainerProfile.c
index dfa77b0..80708fa 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:
@@ -510,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:
@@ -522,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);
@@ -543,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
@@ -560,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;
@@ -815,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();
@@ -888,7 +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_VAR_CLEAN:
+       case MUT_VAR_DIRTY:
        case THUNK_SELECTOR:
        case IND_PERM:
        case IND_OLDGEN_PERM:
@@ -988,9 +993,12 @@ 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:
 
        // thunks are retainers.
     case THUNK:
@@ -1044,7 +1052,6 @@ isRetainer( StgClosure *c )
     case CONSTR_STATIC:
     case FUN_STATIC:
        // misc
-    case FOREIGN:
     case STABLE_NAME:
     case BCO:
     case ARR_WORDS:
@@ -1409,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.b.bitmap);
-       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;
     case ARG_GEN_BIG:
        retain_large_bitmap(p, GET_FUN_LARGE_BITMAP(fun_info),
-                           size, (StgClosure *)pap, c_child_r);
-       p += size;
+                           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;
@@ -1679,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);
@@ -1771,8 +1786,8 @@ computeRetainerSet( void )
        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) {
@@ -1842,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)",
@@ -2018,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
@@ -2047,97 +2062,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:
-       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 FOREIGN:
-    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