X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=rts%2FGC.c;h=967f48d817f775fa801e89708d7a0a5a0df46c7c;hb=cc4e58b669ea557909bde4307b0cc5fed19de919;hp=a13cd33afadd346ed79e20ac72235ea4e62887eb;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git diff --git a/rts/GC.c b/rts/GC.c index a13cd33..967f48d 100644 --- a/rts/GC.c +++ b/rts/GC.c @@ -42,8 +42,9 @@ #if defined(RTS_GTK_FRONTPANEL) #include "FrontPanel.h" #endif - +#include "Trace.h" #include "RetainerProfile.h" +#include "RaiseAsync.h" #include @@ -172,6 +173,7 @@ static void zero_static_object_list ( StgClosure* first_static ); static rtsBool traverse_weak_ptr_list ( void ); static void mark_weak_ptr_list ( StgWeak **list ); +static rtsBool traverse_blackhole_queue ( void ); static StgClosure * eval_thunk_selector ( nat field, StgSelector * p ); @@ -354,10 +356,7 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) CostCentreStack *prev_CCS; #endif -#if defined(DEBUG) && defined(GRAN) - IF_DEBUG(gc, debugBelch("@@ Starting garbage collection at %ld (%lx)\n", - Now, Now)); -#endif + debugTrace(DEBUG_gc, "starting GC"); #if defined(RTS_USER_SIGNALS) // block signals @@ -515,8 +514,8 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) stp->bitmap = bitmap_bdescr; bitmap = bitmap_bdescr->start; - IF_DEBUG(gc, debugBelch("bitmap_size: %d, bitmap: %p", - bitmap_size, bitmap);); + debugTrace(DEBUG_gc, "bitmap_size: %d, bitmap: %p", + bitmap_size, bitmap); // don't forget to fill it with zeros! memset(bitmap, 0, bitmap_size); @@ -665,6 +664,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) */ markStablePtrTable(mark_root); + /* Mark the root pointer table. + */ + markRootPtrTable(mark_root); + /* ------------------------------------------------------------------------- * Repeatedly scavenge all the areas we know about until there's no * more scavenging to be done. @@ -723,6 +726,11 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) } } + // if any blackholes are alive, make the threads that wait on + // them alive too. + if (traverse_blackhole_queue()) + flag = rtsTrue; + if (flag) { goto loop; } // must be last... invariant is that everything is fully @@ -818,7 +826,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) } copied += mut_list_size; - IF_DEBUG(gc, debugBelch("mut_list_size: %ld (%d vars, %d arrays, %d others)\n", mut_list_size * sizeof(W_), mutlist_MUTVARS, mutlist_MUTARRS, mutlist_OTHERS)); + debugTrace(DEBUG_gc, + "mut_list_size: %lu (%d vars, %d arrays, %d others)", + (unsigned long)(mut_list_size * sizeof(W_)), + mutlist_MUTVARS, mutlist_MUTARRS, mutlist_OTHERS); } for (s = 0; s < generations[g].n_steps; s++) { @@ -1067,7 +1078,10 @@ GarbageCollect ( void (*get_roots)(evac_fn), rtsBool force_major_gc ) int pc_free; adjusted_blocks = (RtsFlags.GcFlags.maxHeapSize - 2 * blocks); - IF_DEBUG(gc, debugBelch("@@ Near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks)); + + debugTrace(DEBUG_gc, "near maximum heap size of 0x%x blocks, blocks = %d, adjusted to %ld", + RtsFlags.GcFlags.maxHeapSize, blocks, adjusted_blocks); + pc_free = adjusted_blocks * 100 / RtsFlags.GcFlags.maxHeapSize; if (pc_free < RtsFlags.GcFlags.pcFreeHeap) /* might even be < 0 */ { heapOverflow(); @@ -1299,8 +1313,10 @@ traverse_weak_ptr_list(void) w->link = weak_ptr_list; weak_ptr_list = w; flag = rtsTrue; - IF_DEBUG(weak, debugBelch("Weak pointer still alive at %p -> %p", - w, w->key)); + + debugTrace(DEBUG_weak, + "weak pointer still alive at %p -> %p", + w, w->key); continue; } else { @@ -1366,16 +1382,6 @@ traverse_weak_ptr_list(void) ; } - // Threads blocked on black holes: if the black hole - // is alive, then the thread is alive too. - if (tmp == NULL && t->why_blocked == BlockedOnBlackHole) { - if (isAlive(t->block_info.closure)) { - t = (StgTSO *)evacuate((StgClosure *)t); - tmp = t; - flag = rtsTrue; - } - } - if (tmp == NULL) { // not alive (yet): leave this thread on the // old_all_threads list. @@ -1434,6 +1440,34 @@ traverse_weak_ptr_list(void) } /* ----------------------------------------------------------------------------- + The blackhole queue + + Threads on this list behave like weak pointers during the normal + phase of garbage collection: if the blackhole is reachable, then + the thread is reachable too. + -------------------------------------------------------------------------- */ +static rtsBool +traverse_blackhole_queue (void) +{ + StgTSO *prev, *t, *tmp; + rtsBool flag; + + flag = rtsFalse; + prev = NULL; + + for (t = blackhole_queue; t != END_TSO_QUEUE; prev=t, t = t->link) { + if (! (tmp = (StgTSO *)isAlive((StgClosure*)t))) { + if (isAlive(t->block_info.closure)) { + t = (StgTSO *)evacuate((StgClosure *)t); + if (prev) prev->link = t; + flag = rtsTrue; + } + } + } + return flag; +} + +/* ----------------------------------------------------------------------------- After GC, the live weak pointer list may have forwarding pointers on it, because a weak pointer object was evacuated after being moved to the live weak pointer list. We remove those forwarding @@ -2168,18 +2202,16 @@ loop: to = copy(q,BLACKHOLE_sizeW(),stp); //ToDo: derive size etc from reverted IP //to = copy(q,size,stp); - IF_DEBUG(gc, - debugBelch("@@ evacuate: RBH %p (%s) to %p (%s)", - q, info_type(q), to, info_type(to))); + debugTrace(DEBUG_gc, "evacuate: RBH %p (%s) to %p (%s)", + q, info_type(q), to, info_type(to)); return to; } - + case BLOCKED_FETCH: ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOD_SIZE); to = copy(q,sizeofW(StgBlockedFetch),stp); - IF_DEBUG(gc, - debugBelch("@@ evacuate: %p (%s) to %p (%s)", - q, info_type(q), to, info_type(to))); + debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)", + q, info_type(q), to, info_type(to)); return to; # ifdef DIST @@ -2188,17 +2220,15 @@ loop: case FETCH_ME: ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE); to = copy(q,sizeofW(StgFetchMe),stp); - IF_DEBUG(gc, - debugBelch("@@ evacuate: %p (%s) to %p (%s)", - q, info_type(q), to, info_type(to))); + debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)", + q, info_type(q), to, info_type(to))); return to; case FETCH_ME_BQ: ASSERT(sizeofW(StgBlockedFetch) >= MIN_PAYLOAD_SIZE); to = copy(q,sizeofW(StgFetchMeBlockingQueue),stp); - IF_DEBUG(gc, - debugBelch("@@ evacuate: %p (%s) to %p (%s)", - q, info_type(q), to, info_type(to))); + debugTrace(DEBUG_gc, "evacuate: %p (%s) to %p (%s)", + q, info_type(q), to, info_type(to))); return to; #endif @@ -2602,10 +2632,8 @@ scavengeTSO (StgTSO *tso) ) { tso->block_info.closure = evacuate(tso->block_info.closure); } - if ( tso->blocked_exceptions != NULL ) { - tso->blocked_exceptions = - (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions); - } + tso->blocked_exceptions = + (StgTSO *)evacuate((StgClosure *)tso->blocked_exceptions); // We don't always chase the link field: TSOs on the blackhole // queue are not automatically alive, so the link field is a @@ -3044,9 +3072,8 @@ scavenge(step *stp) (StgClosure *)rbh->blocking_queue = evacuate((StgClosure *)rbh->blocking_queue); failed_to_evac = rtsTrue; // mutable anyhow. - IF_DEBUG(gc, - debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", - p, info_type(p), (StgClosure *)rbh->blocking_queue)); + debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)", + p, info_type(p), (StgClosure *)rbh->blocking_queue); // ToDo: use size of reverted closure here! p += BLACKHOLE_sizeW(); break; @@ -3061,10 +3088,9 @@ scavenge(step *stp) // follow the link to the rest of the blocking queue (StgClosure *)bf->link = evacuate((StgClosure *)bf->link); - IF_DEBUG(gc, - debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", - bf, info_type((StgClosure *)bf), - bf->node, info_type(bf->node))); + debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it", + bf, info_type((StgClosure *)bf), + bf->node, info_type(bf->node))); p += sizeofW(StgBlockedFetch); break; } @@ -3081,9 +3107,8 @@ scavenge(step *stp) StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p; (StgClosure *)fmbq->blocking_queue = evacuate((StgClosure *)fmbq->blocking_queue); - IF_DEBUG(gc, - debugBelch("@@ scavenge: %p (%s) exciting, isn't it", - p, info_type((StgClosure *)p))); + debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it", + p, info_type((StgClosure *)p))); p += sizeofW(StgFetchMeBlockingQueue); break; } @@ -3436,9 +3461,8 @@ linear_scan: bh->blocking_queue = (StgTSO *)evacuate((StgClosure *)bh->blocking_queue); failed_to_evac = rtsTrue; // mutable anyhow. - IF_DEBUG(gc, - debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", - p, info_type(p), (StgClosure *)rbh->blocking_queue)); + debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)", + p, info_type(p), (StgClosure *)rbh->blocking_queue)); break; } @@ -3451,10 +3475,9 @@ linear_scan: // follow the link to the rest of the blocking queue (StgClosure *)bf->link = evacuate((StgClosure *)bf->link); - IF_DEBUG(gc, - debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", - bf, info_type((StgClosure *)bf), - bf->node, info_type(bf->node))); + debugTrace(DEBUG_gc, "scavenge: %p (%s); node is now %p; exciting, isn't it", + bf, info_type((StgClosure *)bf), + bf->node, info_type(bf->node))); break; } @@ -3469,9 +3492,8 @@ linear_scan: StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p; (StgClosure *)fmbq->blocking_queue = evacuate((StgClosure *)fmbq->blocking_queue); - IF_DEBUG(gc, - debugBelch("@@ scavenge: %p (%s) exciting, isn't it", - p, info_type((StgClosure *)p))); + debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it", + p, info_type((StgClosure *)p))); break; } #endif /* PAR */ @@ -3546,7 +3568,7 @@ linear_scan: // start a new linear scan if the mark stack overflowed at some point if (mark_stack_overflowed && oldgen_scan_bd == NULL) { - IF_DEBUG(gc, debugBelch("scavenge_mark_stack: starting linear scan")); + debugTrace(DEBUG_gc, "scavenge_mark_stack: starting linear scan"); mark_stack_overflowed = rtsFalse; oldgen_scan_bd = oldest_gen->steps[0].old_blocks; oldgen_scan = oldgen_scan_bd->start; @@ -3788,9 +3810,8 @@ scavenge_one(StgPtr p) (StgClosure *)rbh->blocking_queue = evacuate((StgClosure *)rbh->blocking_queue); failed_to_evac = rtsTrue; // mutable anyhow. - IF_DEBUG(gc, - debugBelch("@@ scavenge: RBH %p (%s) (new blocking_queue link=%p)", - p, info_type(p), (StgClosure *)rbh->blocking_queue)); + debugTrace(DEBUG_gc, "scavenge: RBH %p (%s) (new blocking_queue link=%p)", + p, info_type(p), (StgClosure *)rbh->blocking_queue)); // ToDo: use size of reverted closure here! break; } @@ -3804,10 +3825,10 @@ scavenge_one(StgPtr p) // follow the link to the rest of the blocking queue (StgClosure *)bf->link = evacuate((StgClosure *)bf->link); - IF_DEBUG(gc, - debugBelch("@@ scavenge: %p (%s); node is now %p; exciting, isn't it", - bf, info_type((StgClosure *)bf), - bf->node, info_type(bf->node))); + debugTrace(DEBUG_gc, + "scavenge: %p (%s); node is now %p; exciting, isn't it", + bf, info_type((StgClosure *)bf), + bf->node, info_type(bf->node))); break; } @@ -3822,9 +3843,8 @@ scavenge_one(StgPtr p) StgFetchMeBlockingQueue *fmbq = (StgFetchMeBlockingQueue *)p; (StgClosure *)fmbq->blocking_queue = evacuate((StgClosure *)fmbq->blocking_queue); - IF_DEBUG(gc, - debugBelch("@@ scavenge: %p (%s) exciting, isn't it", - p, info_type((StgClosure *)p))); + debugTrace(DEBUG_gc, "scavenge: %p (%s) exciting, isn't it", + p, info_type((StgClosure *)p))); break; } #endif @@ -4152,8 +4172,6 @@ scavenge_stack(StgPtr p, StgPtr stack_end) StgWord bitmap; nat size; - //IF_DEBUG(sanity, debugBelch(" scavenging stack between %p and %p", p, stack_end)); - /* * Each time around this loop, we are looking at a chunk of stack * that starts with an activation record. @@ -4413,11 +4431,11 @@ gcCAFs(void) ASSERT(info->type == IND_STATIC); if (STATIC_LINK(info,p) == NULL) { - IF_DEBUG(gccafs, debugBelch("CAF gc'd at 0x%04lx", (long)p)); - // black hole it - SET_INFO(p,&stg_BLACKHOLE_info); - p = STATIC_LINK2(info,p); - *pp = p; + debugTrace(DEBUG_gccafs, "CAF gc'd at 0x%04lx", (long)p); + // black hole it + SET_INFO(p,&stg_BLACKHOLE_info); + p = STATIC_LINK2(info,p); + *pp = p; } else { pp = &STATIC_LINK2(info,p); @@ -4427,7 +4445,7 @@ gcCAFs(void) } - // debugBelch("%d CAFs live", i); + debugTrace(DEBUG_gccafs, "%d CAFs live", i); } #endif @@ -4601,6 +4619,14 @@ threadPaused(Capability *cap, StgTSO *tso) nat weight_pending = 0; rtsBool prev_was_update_frame; + // Check to see whether we have threads waiting to raise + // exceptions, and we're not blocking exceptions, or are blocked + // interruptibly. This is important; if a thread is running with + // TSO_BLOCKEX and becomes blocked interruptibly, this is the only + // place we ensure that the blocked_exceptions get a chance. + maybePerformBlockedException (cap, tso); + if (tso->what_next == ThreadKilled) { return; } + stack_end = &tso->stack[tso->stack_size]; frame = (StgClosure *)tso->sp; @@ -4622,7 +4648,9 @@ threadPaused(Capability *cap, StgTSO *tso) bh = ((StgUpdateFrame *)frame)->updatee; if (closure_IND(bh) || bh->header.info == &stg_BLACKHOLE_info) { - IF_DEBUG(squeeze, debugBelch("suspending duplicate work: %ld words of stack\n", (StgPtr)frame - tso->sp)); + debugTrace(DEBUG_squeeze, + "suspending duplicate work: %ld words of stack", + (long)((StgPtr)frame - tso->sp)); // If this closure is already an indirection, then // suspend the computation up to this point: @@ -4682,10 +4710,10 @@ threadPaused(Capability *cap, StgTSO *tso) } end: - IF_DEBUG(squeeze, - debugBelch("words_to_squeeze: %d, weight: %d, squeeze: %s\n", - words_to_squeeze, weight, - weight < words_to_squeeze ? "YES" : "NO")); + debugTrace(DEBUG_squeeze, + "words_to_squeeze: %d, weight: %d, squeeze: %s", + words_to_squeeze, weight, + weight < words_to_squeeze ? "YES" : "NO"); // Should we squeeze or not? Arbitrary heuristic: we squeeze if // the number of words we have to shift down is less than the @@ -4707,7 +4735,7 @@ printMutableList(generation *gen) bdescr *bd; StgPtr p; - debugBelch("@@ Mutable list %p: ", gen->mut_list); + debugBelch("mutable list %p: ", gen->mut_list); for (bd = gen->mut_list; bd != NULL; bd = bd->link) { for (p = bd->start; p < bd->free; p++) {