X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=rts%2Fsm%2FCompact.c;h=6de42efae482e7274cc70774490f276eddc8ab51;hp=53eb2fbb86e90473ff9432f3d938434f01eb40ba;hb=5d52d9b64c21dcf77849866584744722f8121389;hpb=6494b3cb78498363a2578a62d6cbbf3f55793e2a diff --git a/rts/sm/Compact.c b/rts/sm/Compact.c index 53eb2fb..6de42ef 100644 --- a/rts/sm/Compact.c +++ b/rts/sm/Compact.c @@ -1,6 +1,6 @@ /* ----------------------------------------------------------------------------- * - * (c) The GHC Team 2001-2006 + * (c) The GHC Team 2001-2008 * * Compacting garbage collector * @@ -13,16 +13,18 @@ #include "PosixSource.h" #include "Rts.h" + +#include "Storage.h" #include "RtsUtils.h" -#include "RtsFlags.h" -#include "OSThreads.h" #include "BlockAlloc.h" -#include "MBlock.h" #include "GC.h" #include "Compact.h" #include "Schedule.h" #include "Apply.h" #include "Trace.h" +#include "Weak.h" +#include "MarkWeak.h" +#include "Stable.h" // Turn off inlining when debugging - it obfuscates things #ifdef DEBUG @@ -83,11 +85,8 @@ thread (StgClosure **p) if (HEAP_ALLOCED(q)) { bd = Bdescr(q); - // a handy way to discover whether the ptr is into the - // compacted area of the old gen, is that the EVACUATED flag - // is zero (it's non-zero for all the other areas of live - // memory). - if ((bd->flags & BF_EVACUATED) == 0) + + if (bd->flags & BF_MARKED) { iptr = *q; switch (GET_CLOSURE_TAG((StgClosure *)iptr)) @@ -109,6 +108,12 @@ thread (StgClosure **p) } } +static void +thread_root (void *user STG_UNUSED, StgClosure **p) +{ + thread(p); +} + // This version of thread() takes a (void *), used to circumvent // warnings from gcc about pointer punning and strict aliasing. STATIC_INLINE void thread_ (void *p) { thread((StgClosure **)p); } @@ -163,7 +168,7 @@ loop: case 1: { StgWord r = *(StgPtr)(q-1); - ASSERT(LOOKS_LIKE_INFO_PTR(UNTAG_CLOSURE((StgClosure *)r))); + ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)UNTAG_CLOSURE((StgClosure *)r))); return r; } case 2: @@ -461,12 +466,13 @@ thread_AP_STACK (StgAP_STACK *ap) static StgPtr thread_TSO (StgTSO *tso) { - thread_(&tso->link); + thread_(&tso->_link); thread_(&tso->global_link); if ( tso->why_blocked == BlockedOnMVar || tso->why_blocked == BlockedOnBlackHole - || tso->why_blocked == BlockedOnException + || tso->why_blocked == BlockedOnMsgThrowTo + || tso->why_blocked == BlockedOnMsgWakeup ) { thread_(&tso->block_info.closure); } @@ -487,6 +493,10 @@ update_fwd_large( bdescr *bd ) for (; bd != NULL; bd = bd->link) { + // nothing to do in a pinned block; it might not even have an object + // at the beginning. + if (bd->flags & BF_PINNED) continue; + p = bd->start; info = get_itbl((StgClosure *)p); @@ -502,13 +512,13 @@ update_fwd_large( bdescr *bd ) case MUT_ARR_PTRS_FROZEN0: // follow everything { - StgPtr next; + StgMutArrPtrs *a; - next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); - for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) { - thread((StgClosure **)p); - } - continue; + a = (StgMutArrPtrs*)p; + for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) { + thread((StgClosure **)p); + } + continue; } case TSO: @@ -613,14 +623,13 @@ thread_obj (StgInfoTable *info, StgPtr p) case FUN: case CONSTR: - case STABLE_NAME: + case PRIM: + case MUT_PRIM: case IND_PERM: case MUT_VAR_CLEAN: case MUT_VAR_DIRTY: - case CAF_BLACKHOLE: - case SE_CAF_BLACKHOLE: - case SE_BLACKHOLE: case BLACKHOLE: + case BLOCKING_QUEUE: { StgPtr end; @@ -635,6 +644,7 @@ thread_obj (StgInfoTable *info, StgPtr p) case WEAK: { StgWeak *w = (StgWeak *)p; + thread(&w->cfinalizer); thread(&w->key); thread(&w->value); thread(&w->finalizer); @@ -644,7 +654,8 @@ thread_obj (StgInfoTable *info, StgPtr p) return p + sizeofW(StgWeak); } - case MVAR: + case MVAR_CLEAN: + case MVAR_DIRTY: { StgMVar *mvar = (StgMVar *)p; thread_(&mvar->head); @@ -683,44 +694,19 @@ thread_obj (StgInfoTable *info, StgPtr p) case MUT_ARR_PTRS_FROZEN0: // follow everything { - StgPtr next; - - next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p); - for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) { + StgMutArrPtrs *a; + + a = (StgMutArrPtrs *)p; + for (p = (P_)a->payload; p < (P_)&a->payload[a->ptrs]; p++) { thread((StgClosure **)p); } - return p; + + return (StgPtr)a + mut_arr_ptrs_sizeW(a); } case TSO: return thread_TSO((StgTSO *)p); - case TVAR_WATCH_QUEUE: - { - StgTVarWatchQueue *wq = (StgTVarWatchQueue *)p; - thread_(&wq->closure); - thread_(&wq->next_queue_entry); - thread_(&wq->prev_queue_entry); - return p + sizeofW(StgTVarWatchQueue); - } - - case TVAR: - { - StgTVar *tvar = (StgTVar *)p; - thread((void *)&tvar->current_value); - thread((void *)&tvar->first_watch_queue_entry); - return p + sizeofW(StgTVar); - } - - case TREC_HEADER: - { - StgTRecHeader *trec = (StgTRecHeader *)p; - thread_(&trec->enclosing_trec); - thread_(&trec->current_chunk); - thread_(&trec->invariants_to_check); - return p + sizeofW(StgTRecHeader); - } - case TREC_CHUNK: { StgWord i; @@ -735,23 +721,6 @@ thread_obj (StgInfoTable *info, StgPtr p) return p + sizeofW(StgTRecChunk); } - case ATOMIC_INVARIANT: - { - StgAtomicInvariant *invariant = (StgAtomicInvariant *)p; - thread_(&invariant->code); - thread_(&invariant->last_execution); - return p + sizeofW(StgAtomicInvariant); - } - - case INVARIANT_CHECK_QUEUE: - { - StgInvariantCheckQueue *queue = (StgInvariantCheckQueue *)p; - thread_(&queue->invariant); - thread_(&queue->my_execution); - thread_(&queue->next_queue_entry); - return p + sizeofW(StgInvariantCheckQueue); - } - default: barf("update_fwd: unknown/strange object %d", (int)(info->type)); return NULL; @@ -845,15 +814,15 @@ update_fwd_compact( bdescr *blocks ) size = p - q; if (free + size > free_bd->start + BLOCK_SIZE_W) { - // unset the next bit in the bitmap to indicate that + // set the next bit in the bitmap to indicate that // this object needs to be pushed into the next // block. This saves us having to run down the // threaded info pointer list twice during the next pass. - unmark(q+1,bd); + mark(q+1,bd); free_bd = free_bd->link; free = free_bd->start; } else { - ASSERT(is_marked(q+1,bd)); + ASSERT(!is_marked(q+1,bd)); } unthread(q,(StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr)); @@ -866,7 +835,7 @@ update_fwd_compact( bdescr *blocks ) } static nat -update_bkwd_compact( step *stp ) +update_bkwd_compact( generation *gen ) { StgPtr p, free; #if 0 @@ -877,7 +846,7 @@ update_bkwd_compact( step *stp ) nat size, free_blocks; StgWord iptr; - bd = free_bd = stp->old_blocks; + bd = free_bd = gen->old_blocks; free = free_bd->start; free_blocks = 1; @@ -912,7 +881,7 @@ update_bkwd_compact( step *stp ) } #endif - if (!is_marked(p+1,bd)) { + if (is_marked(p+1,bd)) { // don't forget to update the free ptr in the block desc. free_bd->free = free; free_bd = free_bd->link; @@ -922,7 +891,7 @@ update_bkwd_compact( step *stp ) iptr = get_threaded_info(p); unthread(p, (StgWord)free + GET_CLOSURE_TAG((StgClosure *)iptr)); - ASSERT(LOOKS_LIKE_INFO_PTR(((StgClosure *)p)->header.info)); + ASSERT(LOOKS_LIKE_INFO_PTR((StgWord)((StgClosure *)p)->header.info)); info = get_itbl((StgClosure *)p); size = closure_sizeW_((StgClosure *)p,info); @@ -954,13 +923,13 @@ update_bkwd_compact( step *stp ) } void -compact(void) +compact(StgClosure *static_objects) { - nat g, s, blocks; - step *stp; + nat g, blocks; + generation *gen; // 1. thread the roots - GetRoots((evac_fn)thread); + markCapabilities((evac_fn)thread_root, NULL); // the weak pointer lists... if (weak_ptr_list != NULL) { @@ -974,15 +943,26 @@ compact(void) for (g = 1; g < RtsFlags.GcFlags.generations; g++) { bdescr *bd; StgPtr p; + nat n; for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) { for (p = bd->start; p < bd->free; p++) { thread((StgClosure **)p); } } + for (n = 0; n < n_capabilities; n++) { + for (bd = capabilities[n].mut_lists[g]; + bd != NULL; bd = bd->link) { + for (p = bd->start; p < bd->free; p++) { + thread((StgClosure **)p); + } + } + } } // the global thread list - thread((void *)&all_threads); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + thread((void *)&generations[g].threads); + } // any threads resurrected during this GC thread((void *)&resurrected_threads); @@ -990,48 +970,46 @@ compact(void) // the task list { Task *task; + InCall *incall; for (task = all_tasks; task != NULL; task = task->all_link) { - if (task->tso) { - thread_(&task->tso); - } + for (incall = task->incall; incall != NULL; + incall = incall->prev_stack) { + if (incall->tso) { + thread_(&incall->tso); + } + } } } // the static objects - thread_static(scavenged_static_objects); + thread_static(static_objects /* ToDo: ok? */); // the stable pointer table - threadStablePtrTable((evac_fn)thread); + threadStablePtrTable((evac_fn)thread_root, NULL); // the CAF list (used by GHCi) - markCAFs((evac_fn)thread); + markCAFs((evac_fn)thread_root, NULL); // 2. update forward ptrs for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - for (s = 0; s < generations[g].n_steps; s++) { - if (g==0 && s ==0) continue; - stp = &generations[g].steps[s]; - debugTrace(DEBUG_gc, "update_fwd: %d.%d", - stp->gen->no, stp->no); - - update_fwd(stp->blocks); - update_fwd_large(stp->scavenged_large_objects); - if (g == RtsFlags.GcFlags.generations-1 && stp->old_blocks != NULL) { - debugTrace(DEBUG_gc, "update_fwd: %d.%d (compact)", - stp->gen->no, stp->no); - update_fwd_compact(stp->old_blocks); - } + gen = &generations[g]; + debugTrace(DEBUG_gc, "update_fwd: %d", g); + + update_fwd(gen->blocks); + update_fwd_large(gen->scavenged_large_objects); + if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) { + debugTrace(DEBUG_gc, "update_fwd: %d (compact)", g); + update_fwd_compact(gen->old_blocks); } } // 3. update backward ptrs - stp = &oldest_gen->steps[0]; - if (stp->old_blocks != NULL) { - blocks = update_bkwd_compact(stp); + gen = oldest_gen; + if (gen->old_blocks != NULL) { + blocks = update_bkwd_compact(gen); debugTrace(DEBUG_gc, - "update_bkwd: %d.%d (compact, old: %d blocks, now %d blocks)", - stp->gen->no, stp->no, - stp->n_old_blocks, blocks); - stp->n_old_blocks = blocks; + "update_bkwd: %d (compact, old: %d blocks, now %d blocks)", + gen->no, gen->n_old_blocks, blocks); + gen->n_old_blocks = blocks; } }