/* -----------------------------------------------------------------------------
- * $Id: GC.c,v 1.55 1999/03/18 17:57:21 simonm Exp $
+ * $Id: GC.c,v 1.67 1999/11/18 16:02:21 sewardj Exp $
*
* (c) The GHC Team 1998-1999
*
#include "GC.h"
#include "BlockAlloc.h"
#include "Main.h"
-#include "DebugProf.h"
+#include "ProfHeap.h"
#include "SchedAPI.h"
#include "Weak.h"
#include "StablePriv.h"
CCCS = CCS_GC;
#endif
- /* We might have been called from Haskell land by _ccall_GC, in
- * which case we need to call threadPaused() because the scheduler
- * won't have done it.
- */
- if (CurrentTSO) { threadPaused(CurrentTSO); }
-
- /* Approximate how much we allocated: number of blocks in the
- * nursery + blocks allocated via allocate() - unused nusery blocks.
- * This leaves a little slop at the end of each block, and doesn't
- * take into account large objects (ToDo).
- */
- allocated = (nursery_blocks * BLOCK_SIZE_W) + allocated_bytes();
- for ( bd = current_nursery->link; bd != NULL; bd = bd->link ) {
- allocated -= BLOCK_SIZE_W;
- }
- if (current_nursery->free < current_nursery->start + BLOCK_SIZE_W) {
- allocated -= (current_nursery->start + BLOCK_SIZE_W)
- - current_nursery->free;
- }
+ /* Approximate how much we allocated */
+ allocated = calcAllocated();
/* Figure out which generation to collect
*/
evac_gen = 0;
get_roots();
- /* And don't forget to mark the TSO if we got here direct from
- * Haskell! */
- if (CurrentTSO) {
- CurrentTSO = (StgTSO *)MarkRoot((StgClosure *)CurrentTSO);
- }
-
/* Mark the weak pointer list, and prepare to detect dead weak
* pointers.
*/
/* Reset the nursery
*/
- for (bd = g0s0->blocks; bd; bd = bd->link) {
- bd->free = bd->start;
- ASSERT(bd->gen == g0);
- ASSERT(bd->step == g0s0);
- IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE));
- }
- current_nursery = g0s0->blocks;
+ resetNurseries();
/* start any pending finalizers */
scheduleFinalizers(old_weak_ptr_list);
/* restore enclosing cost centre */
#ifdef PROFILING
+ heapCensus();
CCCS = prev_CCS;
#endif
StgClosure *
isAlive(StgClosure *p)
{
- StgInfoTable *info;
+ const StgInfoTable *info;
while (1) {
}
step = bd->step->to;
}
+#ifdef DEBUG
+ else step = NULL; /* make sure copy() will crash if HEAP_ALLOCED is wrong */
+#endif
/* make sure the info pointer is into text space */
ASSERT(q && (LOOKS_LIKE_GHC_INFO(GET_INFO(q))
|| IS_HUGS_CONSTR_INFO(GET_INFO(q))));
-
info = get_itbl(q);
+
switch (info -> type) {
case BCO:
- return copy(q,bco_sizeW(stgCast(StgBCO*,q)),step);
+ {
+ nat size = bco_sizeW((StgBCO*)q);
+
+ if (size >= LARGE_OBJECT_THRESHOLD/sizeof(W_)) {
+ evacuate_large((P_)q, rtsFalse);
+ to = q;
+ } else {
+ /* just copy the block */
+ to = copy(q,size,step);
+ }
+ return to;
+ }
case MUT_VAR:
ASSERT(q->header.info != &MUT_CONS_info);
return copy(q,sizeW_fromITBL(info),step);
case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
case BLACKHOLE:
return copyPart(q,BLACKHOLE_sizeW(),sizeofW(StgHeader),step);
/* aargh - do recursively???? */
case CAF_UNENTERED:
case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
case BLACKHOLE:
case BLACKHOLE_BQ:
/* not evaluated yet */
break;
default:
- barf("evacuate: THUNK_SELECTOR: strange selectee");
+ barf("evacuate: THUNK_SELECTOR: strange selectee %d",
+ (int)(selectee_info->type));
}
}
return copy(q,THUNK_SELECTOR_sizeW(),step);
return q;
default:
- barf("evacuate: strange closure type");
+ barf("evacuate: strange closure type %d", (int)(info->type));
}
barf("evacuate");
break;
default:
- barf("relocate_TSO");
+ barf("relocate_TSO %d", (int)(get_itbl(su)->type));
}
break;
}
If the SRT entry hasn't got bit 0 set, the SRT entry points to a
closure that's fixed at link-time, and no extra magic is required.
*/
-#ifdef HAVE_WIN32_DLL_SUPPORT
+#ifdef ENABLE_WIN32_DLL_SUPPORT
if ( stgCast(unsigned long,*srt) & 0x1 ) {
evacuate(*stgCast(StgClosure**,(stgCast(unsigned long, *srt) & ~0x1)));
} else {
break;
case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
case BLACKHOLE:
p += BLACKHOLE_sizeW();
break;
evac_gen = 0;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if (tso->blocked_on) {
- tso->blocked_on = evacuate(tso->blocked_on);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
}
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
static rtsBool
scavenge_one(StgClosure *p)
{
- StgInfoTable *info;
+ const StgInfoTable *info;
rtsBool no_luck;
ASSERT(p && (LOOKS_LIKE_GHC_INFO(GET_INFO(p))
}
case CAF_BLACKHOLE:
+ case SE_CAF_BLACKHOLE:
+ case SE_BLACKHOLE:
case BLACKHOLE:
break;
static void
scavenge_mut_once_list(generation *gen)
{
- StgInfoTable *info;
+ const StgInfoTable *info;
StgMutClosure *p, *next, *new_list;
p = gen->mut_once_list;
default:
/* shouldn't have anything else on the mutables list */
- barf("scavenge_mut_once_list: strange object?");
+ barf("scavenge_mut_once_list: strange object? %d", (int)(info->type));
}
}
static void
scavenge_mutable_list(generation *gen)
{
- StgInfoTable *info;
+ const StgInfoTable *info;
StgMutClosure *p, *next;
p = gen->saved_mut_list;
StgTSO *tso = (StgTSO *)p;
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if (tso->blocked_on) {
- tso->blocked_on = evacuate(tso->blocked_on);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
}
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
continue;
}
+ /* Happens if a BLACKHOLE_BQ in the old generation is updated:
+ */
+ case IND_OLDGEN:
+ case IND_OLDGEN_PERM:
+ /* Try to pull the indirectee into this generation, so we can
+ * remove the indirection from the mutable list.
+ */
+ evac_gen = gen->no;
+ ((StgIndOldGen *)p)->indirectee =
+ evacuate(((StgIndOldGen *)p)->indirectee);
+ evac_gen = 0;
+
+ if (failed_to_evac) {
+ failed_to_evac = rtsFalse;
+ p->mut_link = gen->mut_once_list;
+ gen->mut_once_list = p;
+ } else {
+ p->mut_link = NULL;
+ }
+ continue;
+
default:
/* shouldn't have anything else on the mutables list */
- barf("scavenge_mut_list: strange object?");
+ barf("scavenge_mutable_list: strange object? %d", (int)(info->type));
}
}
}
*/
while (p < stack_end) {
- q = *stgCast(StgPtr*,p);
+ q = *(P_ *)p;
/* If we've got a tag, skip over that many words on the stack */
- if (IS_ARG_TAG(stgCast(StgWord,q))) {
+ if (IS_ARG_TAG((W_)q)) {
p += ARG_SIZE(q);
p++; continue;
}
/* Is q a pointer to a closure?
*/
-
- if (! LOOKS_LIKE_GHC_INFO(q)) {
+ if (! LOOKS_LIKE_GHC_INFO(q) ) {
#ifdef DEBUG
if ( 0 && LOOKS_LIKE_STATIC_CLOSURE(q) ) { /* Is it a static closure? */
ASSERT(closure_STATIC(stgCast(StgClosure*,q)));
* record. All activation records have 'bitmap' style layout
* info.
*/
- info = get_itbl(stgCast(StgClosure*,p));
+ info = get_itbl((StgClosure *)p);
switch (info->type) {
/* Dynamic bitmap: the mask is stored on the stack */
case RET_DYN:
- bitmap = stgCast(StgRetDyn*,p)->liveness;
- p = &payloadWord(stgCast(StgRetDyn*,p),0);
+ bitmap = ((StgRetDyn *)p)->liveness;
+ p = (P_)&((StgRetDyn *)p)->payload[0];
goto small_bitmap;
/* probably a slow-entry point return address: */
recordMutable((StgMutClosure *)to);
continue;
default:
+ /* will never be SE_{,CAF_}BLACKHOLE, since we
+ don't push an update frame for single-entry thunks. KSW 1999-01. */
barf("scavenge_stack: UPDATE_FRAME updatee");
}
}
tso = (StgTSO *)p;
/* chase the link field for any TSOs on the same queue */
(StgClosure *)tso->link = evacuate((StgClosure *)tso->link);
- if (tso->blocked_on) {
- tso->blocked_on = evacuate(tso->blocked_on);
+ if ( tso->why_blocked == BlockedOnMVar
+ || tso->why_blocked == BlockedOnBlackHole) {
+ tso->block_info.closure = evacuate(tso->block_info.closure);
}
/* scavenge this thread's stack */
scavenge_stack(tso->sp, &(tso->stack[tso->stack_size]));
new->link = enteredCAFs;
enteredCAFs = new;
} else {
- ASSERT(0);
+ /* ASSERT(0); */
SET_INFO(caf,&CAF_UNENTERED_info);
caf->value = (StgClosure*)0xdeadbeef;
caf->link = (StgCAF*)0xdeadbeef;
if (bh->header.info != &BLACKHOLE_BQ_info &&
bh->header.info != &CAF_BLACKHOLE_info) {
+#if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
+ fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
+#endif
SET_INFO(bh,&BLACKHOLE_info);
}
* slower --SDM
*/
#if 0 /* do it properly... */
- if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info) {
+# if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
+# error Unimplemented lazy BH warning. (KSW 1999-01)
+# endif
+ if (GET_INFO(updatee_bypass) == BLACKHOLE_BQ_info
+ || GET_INFO(updatee_bypass) == CAF_BLACKHOLE_info
+ ) {
/* Sigh. It has one. Don't lose those threads! */
if (GET_INFO(updatee_keep) == BLACKHOLE_BQ_info) {
/* Urgh. Two queues. Merge them. */
#endif
TICK_UPD_SQUEEZED();
- UPD_IND(updatee_bypass, updatee_keep); /* this wakes the threads up */
+ /* wasn't there something about update squeezing and ticky to be
+ * sorted out? oh yes: we aren't counting each enter properly
+ * in this case. See the log somewhere. KSW 1999-04-21
+ */
+ UPD_IND_NOLOCK(updatee_bypass, updatee_keep); /* this wakes the threads up */
sp = (P_)frame - 1; /* sp = stuff to slide */
displacement += sizeofW(StgUpdateFrame);
*/
if (is_update_frame) {
StgBlockingQueue *bh = (StgBlockingQueue *)frame->updatee;
- if (bh->header.info != &BLACKHOLE_BQ_info &&
+ if (bh->header.info != &BLACKHOLE_info &&
+ bh->header.info != &BLACKHOLE_BQ_info &&
bh->header.info != &CAF_BLACKHOLE_info) {
+#if (!defined(LAZY_BLACKHOLING)) && defined(DEBUG)
+ fprintf(stderr,"Unexpected lazy BHing required at 0x%04x\n",(int)bh);
+#endif
SET_INFO(bh,&BLACKHOLE_info);
}
}
projects / ghc-hetmet.git / blobdiff