Commit dfd7d6d0 authored by simonmar's avatar simonmar

[project @ 2001-07-23 17:23:19 by simonmar]

Add a compacting garbage collector.

It isn't enabled by default, as there are still a couple of problems:
there's a fallback case I haven't implemented yet which means it will
occasionally bomb out, and speed-wise it's quite a bit slower than the
copying collector (about 1.8x slower).

Until I can make it go faster, it'll only be useful when you're
actually running low on real memory.

'+RTS -c' to enable it.

Oh, and I cleaned up a few things in the RTS while I was there, and
fixed one or two possibly real bugs in the existing GC.
parent 9528fa3e
/* -----------------------------------------------------------------------------
* $Id: Block.h,v 1.8 2001/07/23 10:47:16 simonmar Exp $
* $Id: Block.h,v 1.9 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -44,11 +44,14 @@ typedef struct _bdescr {
StgPtr start; /* start addr of memory */
StgPtr free; /* first free byte of memory */
struct _bdescr *link; /* used for chaining blocks together */
struct _bdescr *back; /* used (occasionally) for doubly-linked lists*/
union {
struct _bdescr *back; /* used (occasionally) for doubly-linked lists*/
StgWord *bitmap;
} u;
unsigned int gen_no; /* generation */
struct _step *step; /* step */
StgWord32 blocks; /* no. of blocks (if grp head, 0 otherwise) */
StgWord32 evacuated; /* block is in to-space */
StgWord32 flags; /* block is in to-space */
#if SIZEOF_VOID_P == 8
StgWord32 _padding[2];
#else
......@@ -66,6 +69,9 @@ typedef struct _bdescr {
#define BDESCR_SHIFT 5
#endif
#define BF_EVACUATED 1
#define BF_LARGE 2
/* Finding the block descriptor for a given block -------------------------- */
static inline bdescr *Bdescr(StgPtr p)
......
/* ----------------------------------------------------------------------------
* $Id: ClosureTypes.h,v 1.15 2001/03/22 03:51:09 hwloidl Exp $
* $Id: ClosureTypes.h,v 1.16 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -67,20 +67,21 @@
#define MUT_ARR_PTRS 53
#define MUT_ARR_PTRS_FROZEN 54
#define MUT_VAR 55
#define WEAK 56
#define FOREIGN 57
#define STABLE_NAME 58
#define MUT_CONS 56
#define WEAK 57
#define FOREIGN 58
#define STABLE_NAME 59
#define TSO 59
#define BLOCKED_FETCH 60
#define FETCH_ME 61
#define FETCH_ME_BQ 62
#define RBH 63
#define TSO 60
#define BLOCKED_FETCH 61
#define FETCH_ME 62
#define FETCH_ME_BQ 63
#define RBH 64
#define EVACUATED 64
#define EVACUATED 65
#define REMOTE_REF 65
#define REMOTE_REF 66
#define N_CLOSURE_TYPES 66
#define N_CLOSURE_TYPES 67
#endif /* CLOSURETYPES_H */
/* -----------------------------------------------------------------------------
* $Id: Stable.h,v 1.7 2000/11/07 17:05:47 simonmar Exp $
* $Id: Stable.h,v 1.8 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
......@@ -33,6 +33,7 @@ extern StgStablePtr getStablePtr(StgPtr p);
typedef struct {
StgPtr addr; /* Haskell object, free list, or NULL */
StgPtr old; /* old Haskell object, used during GC */
StgWord weight; /* used for reference counting */
StgClosure *sn_obj; /* the StableName object (or NULL) */
} snEntry;
......
/* -----------------------------------------------------------------------------
* $Id: StgStorage.h,v 1.8 2001/07/23 10:47:16 simonmar Exp $
* $Id: StgStorage.h,v 1.9 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team, 1998-1999
*
......@@ -55,17 +55,19 @@ typedef struct _step {
struct _generation *gen; /* generation this step belongs to */
unsigned int gen_no; /* generation number (cached) */
bdescr *large_objects; /* large objects (doubly linked) */
int is_compacted; /* compact this step */
/* temporary use during GC: */
StgPtr hp; /* next free locn in to-space */
StgPtr hpLim; /* end of current to-space block */
bdescr *hp_bd; /* bdescr of current to-space block */
bdescr *to_space; /* bdescr of first to-space block */
unsigned int to_blocks; /* number of blocks in to-space */
bdescr *to_blocks; /* bdescr of first to-space block */
unsigned int n_to_blocks; /* number of blocks in to-space */
bdescr *scan_bd; /* block currently being scanned */
StgPtr scan; /* scan pointer in current block */
bdescr *new_large_objects; /* large objects collected so far */
bdescr *scavenged_large_objects; /* live large objects after GC (dbl link) */
bdescr *bitmap; /* bitmap for compacting collection */
} step;
typedef struct _generation {
......@@ -104,12 +106,18 @@ typedef struct _generation {
#define CloseNursery(hp) (CurrentNursery->free = (P_)(hp)+1)
/* -----------------------------------------------------------------------------
Prototype for an evacuate-like function
-------------------------------------------------------------------------- */
typedef void (*evac_fn)(StgClosure **);
/* -----------------------------------------------------------------------------
Trigger a GC from Haskell land.
-------------------------------------------------------------------------- */
extern void performGC(void);
extern void performMajorGC(void);
extern void performGCWithRoots(void (*get_roots)(void));
extern void performGCWithRoots(void (*get_roots)(evac_fn));
#endif /* STGSTORAGE_H */
/* -----------------------------------------------------------------------------
* $Id: StgTypes.h,v 1.15 2000/11/07 17:05:47 simonmar Exp $
* $Id: StgTypes.h,v 1.16 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team, 1998-2000
*
......@@ -97,6 +97,8 @@ typedef StgWord32 StgWord;
#endif
#endif
#define W_MASK (sizeof(W_)-1)
typedef void* StgAddr;
/*
......
/* -----------------------------------------------------------------------------
* $Id: BlockAlloc.c,v 1.8 2001/07/23 10:47:16 simonmar Exp $
* $Id: BlockAlloc.c,v 1.9 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team 1998-2000
*
......@@ -63,6 +63,8 @@ allocGroup(nat n)
void *mblock;
bdescr *bd, **last;
ASSERT(n != 0);
if (n > BLOCKS_PER_MBLOCK) {
return allocMegaGroup(BLOCKS_TO_MBLOCKS(n));
}
......
/* -----------------------------------------------------------------------------
* $Id: ClosureFlags.c,v 1.9 2001/03/22 03:51:10 hwloidl Exp $
* $Id: ClosureFlags.c,v 1.10 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team 1998-1999
*
......@@ -25,7 +25,7 @@ StgWord16 closure_flags[] = {
/* 0 1 2 3 4 5 6 7 */
/* HNF BTM NS STA THU MUT UPT SRT */
[INVALID_OBJECT ] = ( 0 ),
[CONSTR ] = (_HNF| _NS ),
[CONSTR_1_0 ] = (_HNF| _NS ),
......@@ -60,7 +60,7 @@ StgWord16 closure_flags[] = {
[IND_PERM ] = ( _NS |_IND ),
[IND_OLDGEN_PERM ] = ( _NS |_IND ),
[IND_STATIC ] = ( _NS|_STA |_IND ),
[CAF_BLACKHOLE ] = ( _BTM|_NS| _MUT|_UPT ),
[CAF_BLACKHOLE ] = ( _BTM|_NS| _UPT ),
[RET_BCO ] = ( _BTM ),
[RET_SMALL ] = ( _BTM| _SRT ),
[RET_VEC_SMALL ] = ( _BTM| _SRT ),
......@@ -71,15 +71,16 @@ StgWord16 closure_flags[] = {
[CATCH_FRAME ] = ( _BTM ),
[STOP_FRAME ] = ( _BTM ),
[SEQ_FRAME ] = ( _BTM ),
[BLACKHOLE ] = ( _NS| _MUT|_UPT ),
[BLACKHOLE ] = ( _NS| _UPT ),
[BLACKHOLE_BQ ] = ( _NS| _MUT|_UPT ),
[SE_BLACKHOLE ] = ( _NS| _UPT ),
[SE_CAF_BLACKHOLE ] = ( _NS| _UPT ),
[MVAR ] = (_HNF| _NS| _MUT|_UPT ),
[ARR_WORDS ] = (_HNF| _NS| _UPT ),
[MUT_ARR_PTRS ] = (_HNF| _NS| _MUT|_UPT ),
[MUT_ARR_PTRS_FROZEN ] = (_HNF| _NS| _MUT|_UPT ),
[MUT_ARR_PTRS_FROZEN ] = (_HNF| _NS| _UPT ),
[MUT_VAR ] = (_HNF| _NS| _MUT|_UPT ),
[MUT_CONS ] = (_HNF| _NS| _UPT ),
[WEAK ] = (_HNF| _NS| _UPT ),
[FOREIGN ] = (_HNF| _NS| _UPT ),
[STABLE_NAME ] = (_HNF| _NS| _UPT ),
......
This diff is collapsed.
/* -----------------------------------------------------------------------------
* $Id: GC.h,v 1.6 2000/04/11 16:36:53 sewardj Exp $
*
* (c) The GHC Team, 1998-1999
*
* Prototypes for functions in GC.c
*
* ---------------------------------------------------------------------------*/
void threadPaused(StgTSO *);
StgClosure *isAlive(StgClosure *p);
void GarbageCollect ( void (*get_roots)(void), rtsBool force_major_gc );
/* -----------------------------------------------------------------------------
* $Id: GCCompact.c,v 1.1 2001/07/23 17:23:19 simonmar Exp $
*
* (c) The GHC Team 2001
*
* Compacting garbage collector
*
* ---------------------------------------------------------------------------*/
#include "Rts.h"
#include "RtsUtils.h"
#include "RtsFlags.h"
#include "Storage.h"
#include "BlockAlloc.h"
#include "MBlock.h"
#include "GCCompact.h"
#include "Schedule.h"
#include "StablePriv.h"
static inline void
thread( StgPtr p )
{
StgPtr q = (StgPtr)*p;
ASSERT(!LOOKS_LIKE_GHC_INFO(q));
if (HEAP_ALLOCED(q)) {
*p = (StgWord)*q;
*q = (StgWord)p;
}
}
static inline void
unthread( StgPtr p, StgPtr free )
{
StgPtr q = (StgPtr)*p, r;
while (!LOOKS_LIKE_GHC_INFO(q)) {
r = (StgPtr)*q;
*q = (StgWord)free;
q = r;
}
*p = (StgWord)q;
}
static inline StgInfoTable *
get_threaded_info( StgPtr p )
{
StgPtr q = (P_)GET_INFO((StgClosure *)p);
while (!LOOKS_LIKE_GHC_INFO(q)) {
q = (P_)*q;
}
return INFO_PTR_TO_STRUCT((StgInfoTable *)q);
}
// A word-aligned memmove will be faster for small objects than libc's or gcc's.
// Remember, the two regions *might* overlap, but: to <= from.
static inline void
move(StgPtr to, StgPtr from, nat size)
{
for(; size > 0; --size) {
*to++ = *from++;
}
}
static inline nat
obj_sizeW( StgClosure *p, StgInfoTable *info )
{
switch (info->type) {
case FUN_0_1:
case CONSTR_0_1:
case FUN_1_0:
case CONSTR_1_0:
return sizeofW(StgHeader) + 1;
case THUNK_0_1:
case THUNK_0_2:
case FUN_0_2:
case CONSTR_0_2:
case THUNK_1_0:
case THUNK_1_1:
case FUN_1_1:
case CONSTR_1_1:
case THUNK_2_0:
case FUN_2_0:
case CONSTR_2_0:
return sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
case THUNK_SELECTOR:
return THUNK_SELECTOR_sizeW();
case AP_UPD:
case PAP:
return pap_sizeW((StgPAP *)p);
case ARR_WORDS:
return arr_words_sizeW((StgArrWords *)p);
case MUT_ARR_PTRS:
case MUT_ARR_PTRS_FROZEN:
return mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
case TSO:
return tso_sizeW((StgTSO *)p);
default:
return sizeW_fromITBL(info);
}
}
static void
thread_static( StgClosure* p )
{
const StgInfoTable *info;
// keep going until we've threaded all the objects on the linked
// list...
while (p != END_OF_STATIC_LIST) {
info = get_itbl(p);
switch (info->type) {
case IND_STATIC:
thread((StgPtr)&((StgInd *)p)->indirectee);
break;
case THUNK_STATIC:
case FUN_STATIC:
case CONSTR_STATIC:
break;
default:
barf("thread_static: strange closure %d", (int)(info->type));
}
p = STATIC_LINK(info,p);
}
}
static void
thread_stack(StgPtr p, StgPtr stack_end)
{
StgPtr q;
const StgInfoTable* info;
StgWord32 bitmap;
// highly similar to scavenge_stack, but we do pointer threading here.
while (p < stack_end) {
q = (StgPtr)*p;
// If we've got a tag, skip over that many words on the stack
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) ) {
thread(p);
p++;
continue;
}
// Otherwise, q must be the info pointer of an activation
// record. All activation records have 'bitmap' style layout
// info.
//
info = get_itbl((StgClosure *)p);
switch (info->type) {
// Dynamic bitmap: the mask is stored on the stack
case RET_DYN:
bitmap = ((StgRetDyn *)p)->liveness;
p = (P_)&((StgRetDyn *)p)->payload[0];
goto small_bitmap;
// probably a slow-entry point return address:
case FUN:
case FUN_STATIC:
p++;
continue;
// small bitmap (< 32 entries, or 64 on a 64-bit machine)
case UPDATE_FRAME:
case STOP_FRAME:
case CATCH_FRAME:
case SEQ_FRAME:
case RET_BCO:
case RET_SMALL:
case RET_VEC_SMALL:
bitmap = info->layout.bitmap;
p++;
// this assumes that the payload starts immediately after the info-ptr
small_bitmap:
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
thread(p);
}
p++;
bitmap = bitmap >> 1;
}
continue;
// large bitmap (> 32 entries)
case RET_BIG:
case RET_VEC_BIG:
{
StgPtr q;
StgLargeBitmap *large_bitmap;
nat i;
large_bitmap = info->layout.large_bitmap;
p++;
for (i=0; i<large_bitmap->size; i++) {
bitmap = large_bitmap->bitmap[i];
q = p + sizeof(W_) * 8;
while (bitmap != 0) {
if ((bitmap & 1) == 0) {
thread(p);
}
p++;
bitmap = bitmap >> 1;
}
if (i+1 < large_bitmap->size) {
while (p < q) {
thread(p);
p++;
}
}
}
continue;
}
default:
barf("thread_stack: weird activation record found on stack: %d",
(int)(info->type));
}
}
}
static void
update_fwd_large( bdescr *bd )
{
StgPtr p;
const StgInfoTable* info;
for (; bd != NULL; bd = bd->link) {
p = bd->start;
unthread(p,p);
info = get_itbl((StgClosure *)p);
switch (info->type) {
case ARR_WORDS:
// nothing to follow
continue;
case MUT_ARR_PTRS:
case MUT_ARR_PTRS_FROZEN:
// follow everything
{
StgPtr next;
next = p + mut_arr_ptrs_sizeW((StgMutArrPtrs*)p);
for (p = (P_)((StgMutArrPtrs *)p)->payload; p < next; p++) {
thread(p);
}
continue;
}
case TSO:
{
StgTSO *tso = (StgTSO *)p;
thread_stack(tso->sp, &(tso->stack[tso->stack_size]));
continue;
}
case AP_UPD:
case PAP:
{
StgPAP* pap = (StgPAP *)p;
thread((StgPtr)&pap->fun);
thread_stack((P_)pap->payload, (P_)pap->payload + pap->n_args);
continue;
}
default:
barf("update_fwd_large: unknown/strange object %d", (int)(info->type));
}
}
}
static void
update_fwd( bdescr *blocks )
{
StgPtr p;
bdescr *bd;
StgInfoTable *info;
bd = blocks;
#if defined(PAR)
barf("update_fwd: ToDo");
#endif
// cycle through all the blocks in the step
for (; bd != NULL; bd = bd->link) {
p = bd->start;
// linearly scan the objects in this block
while (p < bd->free) {
/* unthread the info ptr */
unthread(p,p);
info = get_itbl((StgClosure *)p);
ASSERT(p && (LOOKS_LIKE_GHC_INFO(info)
|| IS_HUGS_CONSTR_INFO(info)));
switch (info->type) {
case FUN_0_1:
case CONSTR_0_1:
p += sizeofW(StgHeader) + 1;
break;
case FUN_1_0:
case CONSTR_1_0:
thread((StgPtr)&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 1;
break;
case THUNK_1_0:
thread((StgPtr)&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2; // MIN_UPD_SIZE
break;
case THUNK_0_1: // MIN_UPD_SIZE
case THUNK_0_2:
case FUN_0_2:
case CONSTR_0_2:
p += sizeofW(StgHeader) + 2;
break;
case THUNK_1_1:
case FUN_1_1:
case CONSTR_1_1:
thread((StgPtr)&((StgClosure *)p)->payload[0]);
p += sizeofW(StgHeader) + 2;
break;
case THUNK_2_0:
case FUN_2_0:
case CONSTR_2_0:
thread((StgPtr)&((StgClosure *)p)->payload[0]);
thread((StgPtr)&((StgClosure *)p)->payload[1]);
p += sizeofW(StgHeader) + 2;
break;
case FUN:
case THUNK:
case CONSTR:
case FOREIGN:
case STABLE_NAME:
case BCO:
case IND_PERM:
case MUT_VAR:
case MUT_CONS:
case CAF_BLACKHOLE:
case SE_CAF_BLACKHOLE:
case SE_BLACKHOLE:
case BLACKHOLE:
case BLACKHOLE_BQ:
{
StgPtr end;
end = (P_)((StgClosure *)p)->payload +
info->layout.payload.ptrs;
for (p = (P_)((StgClosure *)p)->payload; p < end; p++) {
thread(p);
}
p += info->layout.payload.nptrs;
break;
}
// the info table for a weak ptr lies about the number of ptrs
// (because we have special GC routines for them, but we
// want to use the standard evacuate code). So we have to
// special case here.
case WEAK:
{
StgWeak *w = (StgWeak *)p;
thread((StgPtr)&w->key);
thread((StgPtr)&w->value);
thread((StgPtr)&w->finalizer);
if (w->link != NULL) {
thread((StgPtr)&w->link);
}
p += sizeofW(StgWeak);
break;
}