Fix retainer profiling

[ghc-hetmet.git] / rts / RetainerProfile.c

diff --git a/rts/RetainerProfile.c b/rts/RetainerProfile.c
index 23d6f9d..f752506 100644 (file)
--- a/rts/RetainerProfile.c
+++ b/rts/RetainerProfile.c
@@ -364,8 +364,7 @@ find_srt( stackPos *info )
        bitmap = info->next.srt.srt_bitmap;
        while (bitmap != 0) {
            if ((bitmap & 1) != 0) {
-#ifdef ENABLE_WIN32_DLL_SUPPORT
-               
+#if defined(__PIC__) && defined(mingw32_TARGET_OS)
                if ((unsigned long)(*(info->next.srt.srt)) & 0x1)
                    c = (* (StgClosure **)((unsigned long)*(info->next.srt.srt)) & ~0x1);
                else
@@ -618,9 +617,7 @@ push( StgClosure *c, retainer c_child_r, StgClosure **first_child )
     case RET_DYN:
     case RET_BCO:
     case RET_SMALL:
-    case RET_VEC_SMALL:
     case RET_BIG:
-    case RET_VEC_BIG:
        // invalid objects
     case IND:
     case BLOCKED_FETCH:
@@ -984,9 +981,7 @@ pop( StgClosure **c, StgClosure **cp, retainer *r )
        case STOP_FRAME:
        case RET_BCO:
        case RET_SMALL:
-       case RET_VEC_SMALL:
        case RET_BIG:
-       case RET_VEC_BIG:
            // invalid objects
        case IND:
        case BLOCKED_FETCH:
@@ -1150,9 +1145,7 @@ isRetainer( StgClosure *c )
     case RET_DYN:
     case RET_BCO:
     case RET_SMALL:
-    case RET_VEC_SMALL:
     case RET_BIG:
-    case RET_VEC_BIG:
        // other cases
     case IND:
     case BLOCKED_FETCH:
@@ -1387,7 +1380,6 @@ retainStack( StgClosure *c, retainer c_child_r,
        case CATCH_RETRY_FRAME:
        case ATOMICALLY_FRAME:
        case RET_SMALL:
-       case RET_VEC_SMALL:
            bitmap = BITMAP_BITS(info->i.layout.bitmap);
            size   = BITMAP_SIZE(info->i.layout.bitmap);
            p++;
@@ -1412,7 +1404,6 @@ 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 = GET_LARGE_BITMAP(&info->i)->size;
            p++;
            retain_large_bitmap(p, GET_LARGE_BITMAP(&info->i),
@@ -1448,7 +1439,7 @@ retainStack( StgClosure *c, retainer c_child_r,
            StgFunInfoTable *fun_info;
            
            retainClosure(ret_fun->fun, c, c_child_r);
-           fun_info = get_fun_itbl(ret_fun->fun);
+           fun_info = get_fun_itbl(UNTAG_CLOSURE(ret_fun->fun));
            
            p = (P_)&ret_fun->payload;
            switch (fun_info->f.fun_type) {
@@ -1494,7 +1485,9 @@ retainStack( StgClosure *c, retainer c_child_r,
  * ------------------------------------------------------------------------- */
 
 static INLINE StgPtr
-retain_PAP_payload (StgClosure *pap,  retainer c_child_r, StgClosure *fun, 
+retain_PAP_payload (StgClosure *pap,    /* NOT tagged */
+                    retainer c_child_r, /* NOT tagged */ 
+                    StgClosure *fun,    /* tagged */
                    StgClosure** payload, StgWord n_args)
 {
     StgPtr p;
@@ -1502,6 +1495,7 @@ retain_PAP_payload (StgClosure *pap,  retainer c_child_r, StgClosure *fun,
     StgFunInfoTable *fun_info;
 
     retainClosure(fun, pap, c_child_r);
+    fun = UNTAG_CLOSURE(fun);
     fun_info = get_fun_itbl(fun);
     ASSERT(fun_info->i.type != PAP);
 
@@ -1550,9 +1544,9 @@ retain_PAP_payload (StgClosure *pap,  retainer c_child_r, StgClosure *fun,
 static void
 retainClosure( StgClosure *c0, StgClosure *cp0, retainer r0 )
 {
-    // c = Current closure
-    // cp = Current closure's Parent
-    // r = current closures' most recent Retainer
+    // c = Current closure                          (possibly tagged)
+    // cp = Current closure's Parent                (NOT tagged)
+    // r = current closures' most recent Retainer   (NOT tagged)
     // c_child_r = current closure's children's most recent retainer
     // first_child = first child of c
     StgClosure *c, *cp, *first_child;
@@ -1590,6 +1584,8 @@ loop:
     //debugBelch("inner_loop");
 
 inner_loop:
+    c = UNTAG_CLOSURE(c);
+
     // c  = current closure under consideration,
     // cp = current closure's parent,
     // r  = current closure's most recent retainer
@@ -1802,16 +1798,19 @@ inner_loop:
 static void
 retainRoot( StgClosure **tl )
 {
+    StgClosure *c;
+
     // We no longer assume that only TSOs and WEAKs are roots; any closure can
     // be a root.
 
     ASSERT(isEmptyRetainerStack());
     currentStackBoundary = stackTop;
 
-    if (*tl != &stg_END_TSO_QUEUE_closure && isRetainer(*tl)) {
-       retainClosure(*tl, *tl, getRetainerFrom(*tl));
+    c = UNTAG_CLOSURE(*tl);
+    if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) {
+       retainClosure(c, c, getRetainerFrom(c));
     } else {
-       retainClosure(*tl, *tl, CCS_SYSTEM);
+       retainClosure(c, c, CCS_SYSTEM);
     }
 
     // NOT TRUE: ASSERT(isMember(getRetainerFrom(*tl), retainerSetOf(*tl)));
@@ -2118,8 +2117,8 @@ sanityCheckHeapClosure( StgClosure *c )
 
     if ((((StgWord)RSET(c) & 1) ^ flip) != 0) {
        if (get_itbl(c)->type == CONSTR &&
-           !strcmp(get_itbl(c)->prof.closure_type, "DEAD_WEAK") &&
-           !strcmp(get_itbl(c)->prof.closure_desc, "DEAD_WEAK")) {
+           !strcmp(GET_PROF_TYPE(get_itbl(c)), "DEAD_WEAK") &&
+           !strcmp(GET_PROF_DESC(get_itbl(c)), "DEAD_WEAK")) {
            debugBelch("\tUnvisited dead weak pointer object found: c = %p\n", c);
            costArray[get_itbl(c)->type] += cost(c);
            sumOfNewCost += cost(c);
@@ -2127,7 +2126,7 @@ sanityCheckHeapClosure( StgClosure *c )
            debugBelch(
                    "Unvisited object: flip = %d, c = %p(%d, %s, %s), rs = %p\n",
                    flip, c, get_itbl(c)->type,
-                   get_itbl(c)->prof.closure_type, get_itbl(c)->prof.closure_desc,
+                   get_itbl(c)->prof.closure_type, GET_PROF_DESC(get_itbl(c)),
                    RSET(c));
     } else {
        // debugBelch("sanityCheckHeapClosure) S: flip = %d, c = %p(%d), rs = %p\n", flip, c, get_itbl(c)->type, RSET(c));