diff options
author | partain <unknown> | 1996-01-08 20:28:12 +0000 |
---|---|---|
committer | partain <unknown> | 1996-01-08 20:28:12 +0000 |
commit | e7d21ee4f8ac907665a7e170c71d59e13a01da09 (patch) | |
tree | 93715bf4e6e4bbe8049e4d8d4d3fbd19158a88d6 /ghc/runtime/storage | |
parent | e48474bff05e6cfb506660420f025f694c870d38 (diff) | |
download | haskell-e7d21ee4f8ac907665a7e170c71d59e13a01da09.tar.gz |
[project @ 1996-01-08 20:28:12 by partain]
Initial revision
Diffstat (limited to 'ghc/runtime/storage')
27 files changed, 11531 insertions, 0 deletions
diff --git a/ghc/runtime/storage/Force_GC.lc b/ghc/runtime/storage/Force_GC.lc new file mode 100644 index 0000000000..0e5120a2d6 --- /dev/null +++ b/ghc/runtime/storage/Force_GC.lc @@ -0,0 +1,50 @@ +\section[Force_GC.lc]{Code for Forcing Garbage Collections} + +\begin{code} +#include "rtsdefs.h" +\end{code} + +Only have GC forcing if @FORCE_GC@ defined + +- currently only works with appel GC +- in normal appel GC, if the force_gc flag is set *major* GC occurs + at the next scheduled minor GC if at least GCInterval word allocations have happened + since the last major GC. + (It also occurs when the normal conditions for a major GC is met) +- if the force2s and force_gc flags are set + (forcing appel GC to work as a 2 space GC) GC occurs + at least at every GCInterval word allocations + (it also occurs when the semi-space limit is reached). + Therefore it has no effect if the interval specified is >= semi-space. + + +\begin{code} +#if defined(FORCE_GC) +\end{code} + +\begin{code} +I_ force_GC = 0; /* Global Flag */ +I_ GCInterval = DEFAULT_GC_INTERVAL; /* words alloced */ +I_ alloc_since_last_major_GC = 0; /* words alloced since last major GC */ + + +#endif /* FORCE_GC */ +\end{code} + + + + + + + + + + + + + + + + + + diff --git a/ghc/runtime/storage/SM1s.lc b/ghc/runtime/storage/SM1s.lc new file mode 100644 index 0000000000..51265e5959 --- /dev/null +++ b/ghc/runtime/storage/SM1s.lc @@ -0,0 +1,197 @@ +*************************************************************************** + + COMPACTING GARBAGE COLLECTION + +Additional Global Data Requirements: + ++ All the root locations are in malloced space (and info tables in + static data space). This is to simplify the location list end test. + +*************************************************************************** + +[Someone needs to document this too. KH] + +\begin{code} +#if defined(GC1s) + +ToDo: Soft heap limits + +#define SCAN_REG_DUMP +#include "SMinternal.h" +#include "SMcompacting.h" +#include "SMextn.h" + +REGDUMP(ScanRegDump); + +compactingData compactingInfo = {0, 0, 0, 0, 0}; + +P_ heap_space = 0; /* Address of first word of slab + of memory allocated for heap */ + +P_ hp_start; /* Value of Hp when reduction was resumed */ + +I_ +initHeap( sm ) + smInfo *sm; +{ + if (heap_space == 0) { /* allocates if it doesn't already exist */ + + /* Allocate the roots space */ + sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) ); + + /* Allocate the heap */ + heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_)); + + compactingInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + compactingInfo.bits = (BitWord *)(heap_space + SM_word_heap_size) - compactingInfo.bit_words; + + compactingInfo.heap_words = SM_word_heap_size - compactingInfo.bit_words; + compactingInfo.base = HEAP_FRAME_BASE(heap_space, compactingInfo.heap_words); + compactingInfo.lim = HEAP_FRAME_LIMIT(heap_space, compactingInfo.heap_words); + + stat_init("COMPACTING", "", ""); + } + + sm->hp = hp_start = compactingInfo.base - 1; + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + SM_alloc_min = 0; /* No min; alloc size specified */ + + if (sm->hplim > compactingInfo.lim) { + fprintf(stderr, "Not enough heap for requested alloc size\n"); + return -1; + } + } else { + sm->hplim = compactingInfo.lim; + } + + sm->CAFlist = NULL; + +#ifndef PAR + initExtensions( sm ); +#endif /* !PAR */ + + if (SM_trace) { + fprintf(stderr, "COMPACTING Heap: Base 0x%lx, Lim 0x%lx, Bits 0x%lx, bit words 0x%lx\n", + (W_) compactingInfo.base, (W_) compactingInfo.lim, + (W_) compactingInfo.bits, (W_) compactingInfo.bit_words); + fprintf(stderr, "COMPACTING Initial: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) compactingInfo.base, + (W_) compactingInfo.lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + } + + return 0; +} + +I_ +collectHeap(reqsize, sm, do_full_collection) + W_ reqsize; + smInfo *sm; + rtsBool do_full_collection; /* ignored */ +{ + I_ free_space, /* No of words of free space following GC */ + alloc, /* Number of words allocated since last GC */ + resident; /* Number of words remaining after GC */ + + SAVE_REGS(&ScanRegDump); /* Save registers */ + + if (SM_trace) + { + fflush(stdout); /* Flush stdout at start of GC */ + fprintf(stderr, "COMPACTING Start: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n", + (W_) compactingInfo.base, (W_) compactingInfo.lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_))); + } + + alloc = sm->hp - hp_start; + + stat_startGC(alloc); + + /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAN_REG_MAP */ + RESTORE_REGS(&ScanRegDump); + + markHeapRoots(sm, sm->CAFlist, 0, + compactingInfo.base, + compactingInfo.lim, + compactingInfo.bits); + + SAVE_REGS(&ScanRegDump); + /* end of bracket */ + +#ifndef PAR + sweepUpDeadMallocPtrs(sm->MallocPtrList, + compactingInfo.base, + compactingInfo.bits ); +#endif + + LinkCAFs(sm->CAFlist); + + LinkRoots( sm->roots, sm->rootno ); +#ifdef CONCURRENT + LinkSparks(); +#endif +#ifdef PAR + LinkLiveGAs(compactingInfo.base, compactingInfo.bits); +#else + DEBUG_STRING("Linking Stable Pointer Table:"); + LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable); + LinkAStack( MAIN_SpA, stackInfo.botA ); + LinkBStack( MAIN_SuB, stackInfo.botB ); +#endif /* parallel */ + + /* Do Inplace Compaction */ + /* Returns start of next closure, -1 gives last allocated word */ + + sm->hp = Inplace_Compaction(compactingInfo.base, + compactingInfo.lim, + 0, 0, + compactingInfo.bits, + compactingInfo.bit_words +#if ! defined(PAR) + , &(sm->MallocPtrList) +#endif + ) - 1; + + resident = sm->hp - (compactingInfo.base - 1); + DO_MAX_RESIDENCY(resident); /* stats only */ + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + if (sm->hplim > compactingInfo.lim) { + free_space = 0; + } else { + free_space = SM_alloc_size; + } + } else { + sm->hplim = compactingInfo.lim; + free_space = sm->hplim - sm->hp; + } + + hp_start = sm->hp; + + stat_endGC(alloc, compactingInfo.heap_words, resident, ""); + + if (SM_trace) + fprintf(stderr, "COMPACTING Done: base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) compactingInfo.base, (W_) compactingInfo.lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_))); + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating. */ + TrashMem(sm->hp+1, sm->hplim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScanRegDump); /* Restore Registers */ + + if ((SM_alloc_min > free_space) || (reqsize > free_space)) + return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */ + else + return GC_SUCCESS; /* Heap OK */ +} + +#endif /* GC1s */ + +\end{code} + diff --git a/ghc/runtime/storage/SM2s.lc b/ghc/runtime/storage/SM2s.lc new file mode 100644 index 0000000000..1a50a0e841 --- /dev/null +++ b/ghc/runtime/storage/SM2s.lc @@ -0,0 +1,291 @@ +*************************************************************************** + + TWO SPACE COLLECTION + +*************************************************************************** + +\begin{code} +#if defined(GC2s) + +#define SCAV_REG_MAP +#include "SMinternal.h" +#include "SMcopying.h" +#include "SMextn.h" + +REGDUMP(ScavRegDump); + +I_ semispace = 0; /* 0 or 1 */ +semispaceData semispaceInfo[2] + = {{0,0}, {0,0}}; + +P_ heap_space = 0; /* Address of first word of slab + of memory allocated for heap */ + +P_ hp_start; /* Value of Hp when reduction was resumed */ + + +I_ initHeap( sm ) + smInfo *sm; +{ + if (heap_space == 0) { /* allocates if it doesn't already exist */ + + I_ semispaceSize = SM_word_heap_size / 2; + + /* Allocate the roots space */ + sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) ); + + /* Allocate the heap */ + heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_)); + + /* Define the semi-spaces */ + semispaceInfo[0].base = HEAP_FRAME_BASE(heap_space, semispaceSize); + semispaceInfo[1].base = HEAP_FRAME_BASE(heap_space + semispaceSize, semispaceSize); + semispaceInfo[0].lim = HEAP_FRAME_LIMIT(heap_space, semispaceSize); + semispaceInfo[1].lim = HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize); + + stat_init("TWOSPACE", + " No of Roots Caf Caf Astk Bstk", + "Astk Bstk Reg No bytes bytes bytes"); + } + + /* Initialise heap pointer and limit */ + sm->hp = hp_start = semispaceInfo[semispace].base - 1; + sm->hardHpOverflowSize = 0; + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + SM_alloc_min = 0; /* No min; alloc size specified */ + + if (sm->hplim > semispaceInfo[semispace].lim) { + fprintf(stderr, "Not enough heap for requested alloc size\n"); + return -1; + } + } else { + sm->hplim = semispaceInfo[semispace].lim; + } + +#if defined(FORCE_GC) + if (force_GC) { + if (sm->hplim > sm->hp + GCInterval) { + sm->hplim = sm->hp + GCInterval; + } + else { + force_GC = 0; /* forcing GC has no effect, as semi-space is smaller than GCInterval */ + } + } +#endif /* FORCE_GC */ + +#if defined(LIFE_PROFILE) + sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); /* space for HpLim incr */ + if (do_life_prof) { + sm->hplim = sm->hp + LifeInterval; + } +#endif /* LIFE_PROFILE */ + + sm->CAFlist = NULL; + +#ifndef PAR + initExtensions( sm ); +#endif /* !PAR */ + + if (SM_trace) { + fprintf(stderr, "TWO SPACE Heap: 0base, 0lim, 1base, 1lim\n 0x%lx, 0x%lx, 0x%lx, 0x%lx\n", + (W_) semispaceInfo[0].base, (W_) semispaceInfo[0].lim, + (W_) semispaceInfo[1].base, (W_) semispaceInfo[1].lim); + fprintf(stderr, "TWO SPACE Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + semispace, + (W_) semispaceInfo[semispace].base, + (W_) semispaceInfo[semispace].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + } + + return 0; +} + +I_ +collectHeap(reqsize, sm, do_full_collection) + W_ reqsize; + smInfo *sm; + rtsBool do_full_collection; /* ignored */ +{ +#if defined(LIFE_PROFILE) + I_ next_interval; /* if doing profile */ +#endif + + I_ free_space, /* No of words of free space following GC */ + alloc, /* Number of words allocated since last GC */ + resident, /* Number of words remaining after GC */ + extra_caf_words,/* Extra words referenced from CAFs */ + caf_roots, /* Number of CAFs */ + bstk_roots; /* Number of update frames on B stack */ + + fflush(stdout); /* Flush stdout at start of GC */ + SAVE_REGS(&ScavRegDump); /* Save registers */ + +#if defined(LIFE_PROFILE) + if (do_life_prof) { life_profile_setup(); } +#endif /* LIFE_PROFILE */ + +#if defined(USE_COST_CENTRES) + if (interval_expired) { heap_profile_setup(); } +#endif /* USE_COST_CENTRES */ + + if (SM_trace) + fprintf(stderr, "TWO SPACE Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n", + semispace, (W_) semispaceInfo[semispace].base, + (W_) semispaceInfo[semispace].lim, + (W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_)); + + alloc = sm->hp - hp_start; + stat_startGC(alloc); + + /* Set Up For Collecting: + - Flip Spaces + - Set ToHp to point one below bottom of to-space (last allocated) + - Set CAFs to Evac & Upd + */ + + semispace = NEXT_SEMI_SPACE(semispace); + ToHp = semispaceInfo[semispace].base - 1; + Scav = semispaceInfo[semispace].base; + + SetCAFInfoTables( sm->CAFlist ); +#ifdef PAR + EvacuateLocalGAs(rtsTrue); +#else + evacSPTable( sm ); +#endif /* PAR */ + EvacuateRoots( sm->roots, sm->rootno ); +#ifdef CONCURRENT + EvacuateSparks(); +#endif +#ifndef PAR + EvacuateAStack( MAIN_SpA, stackInfo.botA ); + EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots ); +#endif /* !PAR */ + + Scavenge(); + + EvacAndScavengeCAFs( sm->CAFlist, &extra_caf_words, &caf_roots ); + +#ifdef PAR + RebuildGAtables(rtsTrue); +#else + reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); +#endif /* PAR */ + + /* TIDY UP AND RETURN */ + + sm->hp = hp_start = ToHp; /* Last allocated word */ + + resident = sm->hp - (semispaceInfo[semispace].base - 1); + DO_MAX_RESIDENCY(resident); /* stats only */ + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + if (sm->hplim > semispaceInfo[semispace].lim) { + free_space = 0; + } else { + free_space = SM_alloc_size; + } + } else { + sm->hplim = semispaceInfo[semispace].lim; + free_space = sm->hplim - sm->hp; + } + + if (SM_stats_verbose) { + char comment_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu", + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, + caf_roots, extra_caf_words*sizeof(W_), + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_), + (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_)); +#else + /* ToDo: come up with some interesting statistics for the parallel world */ + sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu", + 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0); +#endif + +#if defined(LIFE_PROFILE) + if (do_life_prof) { + strcat(comment_str, " life"); + } +#endif +#if defined(USE_COST_CENTRES) + if (interval_expired) { + strcat(comment_str, " prof"); + } +#endif + + stat_endGC(alloc, SM_word_heap_size, resident, comment_str); + } else { + stat_endGC(alloc, SM_word_heap_size, resident, ""); + } + +#if defined(LIFE_PROFILE) + free_space = free_space / 2; /* space for HpLim incr */ + if (do_life_prof) { + next_interval = life_profile_done(alloc, reqsize); + free_space -= next_interval; /* ensure interval available */ + } +#endif /* LIFE_PROFILE */ + +#if defined(USE_COST_CENTRES) || defined(GUM) + if (interval_expired) { +#if defined(USE_COST_CENTRES) + heap_profile_done(); +#endif + report_cc_profiling(0 /*partial*/); + } +#endif /* USE_COST_CENTRES */ + + if (SM_trace) + fprintf(stderr, "TWO SPACE Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + semispace, (W_) semispaceInfo[semispace].base, + (W_) semispaceInfo[semispace].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_))); + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating and all of the other semispace. */ + TrashMem(sm->hp+1, sm->hplim); + TrashMem(semispaceInfo[NEXT_SEMI_SPACE(semispace)].base, + semispaceInfo[NEXT_SEMI_SPACE(semispace)].lim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + if ( (SM_alloc_min > free_space) || (reqsize > free_space) ) { + return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */ + } else { + +#if defined(FORCE_GC) + if (force_GC) { + if (sm->hplim > sm->hp + GCInterval) { + sm->hplim = sm->hp + GCInterval; + } + } +#endif /* FORCE_GC */ ++ +#if defined(LIFE_PROFILE) + /* space for HpLim incr */ + sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); + if (do_life_prof) { + /* set hplim for next life profile */ + sm->hplim = sm->hp + next_interval; + } +#endif /* LIFE_PROFILE */ + + if (reqsize + sm->hardHpOverflowSize > free_space) { + return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */ + } else { + return( GC_SUCCESS ); /* Heap OK */ + } + } +} + +#endif /* GC2s */ + +\end{code} diff --git a/ghc/runtime/storage/SMalloc.lc b/ghc/runtime/storage/SMalloc.lc new file mode 100644 index 0000000000..fa1bdab8e6 --- /dev/null +++ b/ghc/runtime/storage/SMalloc.lc @@ -0,0 +1,37 @@ +[ + SMalloc seems a BAD choice of name. I expected this to be the routines I + could use to allocate memory, not those used by the storage manager internally. + + KH +] + +Routines that deal with memory allocation: + +All dynamic allocation must be done before the stacks and heap are +allocated. This allows us to use the lower level sbrk routines if +required. + +\begin{code} +#define NULL_REG_MAP +#include "SMinternal.h" + +/* Return a ptr to n StgWords (note: WORDS not BYTES!) or die miserably */ +/* ToDo: Should allow use of valloc to allign on page boundary */ + +char * +#ifdef __STDC__ +xmalloc(size_t n) +#else +xmalloc(n) + size_t n; +#endif +{ + char *space; + + if ((space = (char *) malloc(n)) == NULL) { + MallocFailHook((W_) n); /*msg*/ + EXIT(EXIT_FAILURE); + } + return space; +} +\end{code} diff --git a/ghc/runtime/storage/SMap.lc b/ghc/runtime/storage/SMap.lc new file mode 100644 index 0000000000..e82a986580 --- /dev/null +++ b/ghc/runtime/storage/SMap.lc @@ -0,0 +1,888 @@ +*************************************************************************** + + APPEL'S GARBAGE COLLECTION + +Global heap requirements as for 1s and 2s collectors. + ++ All closures in the old generation that are updated must be + updated with indirections and placed on the linked list of + updated old generation closures. + +*************************************************************************** + +\begin{code} +#if defined(GCap) + +#define SCAV_REG_MAP +#include "SMinternal.h" +#include "SMcopying.h" +#include "SMcompacting.h" +#include "SMextn.h" + +REGDUMP(ScavRegDump); + +appelData appelInfo = {0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0, 0, + 0, {{0, 0}, {0, 0}} + }; + +P_ heap_space = 0; /* Address of first word of slab + of memory allocated for heap */ + +P_ hp_start; /* Value of Hp when reduction was resumed */ + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ +P_ thisbase; /* Start of old gen before this minor collection */ +P_ prevbase; /* Start of old gen before previous minor collection */ +I_ prev_prom = 0; /* Promoted previous minor collection */ +I_ dead_prev_prom = 0; /* Dead words promoted previous minor */ +#endif /* PROMOTION_DATA */ + +#if defined(_GC_DEBUG) +void +debug_look_for (start, stop, villain) + P_ start, stop, villain; +{ + P_ i; + for (i = start; i <= stop; i++) { + if ( (P_) *i == villain ) { + fprintf(stderr, "* %x : %x\n", i, villain); + } + } +} +#endif + +I_ +initHeap( sm ) + smInfo *sm; +{ + if (heap_space == 0) { /* allocates if it doesn't already exist */ + + /* Allocate the roots space */ + sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) ); + + /* Allocate the heap */ + heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_)); + + /* ToDo (ADR): trash entire heap contents */ + + if (SM_force_gc == USE_2s) { + stat_init("TWOSPACE(APPEL)", + " No of Roots Caf Caf Astk Bstk", + "Astk Bstk Reg No bytes bytes bytes"); + } else { + stat_init("APPEL", + " No of Roots Caf Mut- Old Collec Resid", + "Astk Bstk Reg No able Gen tion %heap"); + } + } + sm->hardHpOverflowSize = 0; + + if (SM_force_gc == USE_2s) { + I_ semi_space_words = SM_word_heap_size / 2; + appelInfo.space[0].base = HEAP_FRAME_BASE(heap_space, semi_space_words); + appelInfo.space[1].base = HEAP_FRAME_BASE(heap_space + semi_space_words, semi_space_words); + appelInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, semi_space_words); + appelInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + semi_space_words, semi_space_words); + appelInfo.semi_space = 0; + appelInfo.oldlim = heap_space - 1; /* Never in old generation */ + + sm->hp = hp_start = appelInfo.space[appelInfo.semi_space].base - 1; + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + SM_alloc_min = 0; /* No min; alloc size specified */ + + if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) { + fprintf(stderr, "Not enough heap for requested alloc size\n"); + return -1; + } + } else { + sm->hplim = appelInfo.space[appelInfo.semi_space].lim; + } + +#if defined(FORCE_GC) + if (force_GC) { + if (sm->hplim > sm->hp + GCInterval) { + sm->hplim = sm->hp + GCInterval; + } + else { + /* no point in forcing GC, + as the semi-space is smaller than GCInterval */ + force_GC = 0; + } + } +#endif /* FORCE_GC */ + +#if defined(LIFE_PROFILE) + sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); /* space for HpLim incr */ + if (do_life_prof) { + sm->hplim = sm->hp + LifeInterval; + } +#endif /* LIFE_PROFILE */ + + sm->OldLim = appelInfo.oldlim; + sm->CAFlist = NULL; + +#ifndef PAR + initExtensions( sm ); +#endif + + if (SM_trace) { + fprintf(stderr, "APPEL(2s) Heap: 0x%lx .. 0x%lx\n", + (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size)); + fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + appelInfo.semi_space, + (W_) appelInfo.space[appelInfo.semi_space].base, + (W_) appelInfo.space[appelInfo.semi_space].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + } + return 0; + } + + +/* So not forced 2s */ + + appelInfo.newlim = heap_space + SM_word_heap_size - 1; + if (SM_alloc_size) { + appelInfo.newfixed = SM_alloc_size; + appelInfo.newmin = SM_alloc_size; + appelInfo.newbase = heap_space + SM_word_heap_size - appelInfo.newfixed; + } else { + appelInfo.newfixed = 0; + appelInfo.newmin = SM_alloc_min; + appelInfo.newbase = heap_space + (SM_word_heap_size / 2); + } + + appelInfo.oldbase = heap_space; + appelInfo.oldlim = heap_space - 1; + appelInfo.oldlast = heap_space - 1; + appelInfo.oldmax = heap_space - 1 + SM_word_heap_size - 2*appelInfo.newmin; + + if (appelInfo.oldbase > appelInfo.oldmax) { + fprintf(stderr, "Not enough heap for requested/minimum allocation area\n"); + return -1; + } + + appelInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + appelInfo.bits = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words; + if (appelInfo.bit_words > appelInfo.newmin) + appelInfo.oldmax = heap_space - 1 + SM_word_heap_size - appelInfo.bit_words - appelInfo.newmin; + + if (SM_major_gen_size) { + appelInfo.oldthresh = heap_space -1 + SM_major_gen_size; + if (appelInfo.oldthresh > appelInfo.oldmax) { + fprintf(stderr, "Not enough heap for requested major resid size\n"); + return -1; + } + } else { + appelInfo.oldthresh = heap_space + SM_word_heap_size * 2 / 3; /* Initial threshold -- 2/3rds */ + if (appelInfo.oldthresh > appelInfo.oldmax) + appelInfo.oldthresh = appelInfo.oldmax; + } + + sm->hp = hp_start = appelInfo.newbase - 1; + sm->hplim = appelInfo.newlim; + +#if defined(FORCE_GC) + if (force_GC && (sm->hplim > sm->hp + GCInterval)) { + sm->hplim = sm->hp + GCInterval; + } +#endif /* FORCE_GC */ + + sm->OldLim = appelInfo.oldlim; + + sm->CAFlist = NULL; + appelInfo.OldCAFlist = NULL; + appelInfo.OldCAFno = 0; + +#ifndef PAR + initExtensions( sm ); +#endif + + appelInfo.PromMutables = 0; + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ + prevbase = appelInfo.oldlim + 1; + thisbase = appelInfo.oldlim + 1; +#endif /* PROMOTION_DATA */ + + if (SM_trace) { + fprintf(stderr, "APPEL Heap: 0x%lx .. 0x%lx\n", + (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size)); + fprintf(stderr, "Initial: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx\n", + (W_) appelInfo.newbase, (W_) appelInfo.newlim, + (W_) appelInfo.oldbase, (W_) appelInfo.oldlim, + (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax, + (W_) sm->hp, (W_) sm->hplim); + } + + return 0; +} + +static I_ +collect2s(reqsize, sm) + W_ reqsize; + smInfo *sm; +{ +#if defined(LIFE_PROFILE) + I_ next_interval; /* if doing profile */ +#endif + I_ free_space, /* No of words of free space following GC */ + alloc, /* Number of words allocated since last GC */ + resident, /* Number of words remaining after GC */ + extra_caf_words,/* Extra words referenced from CAFs */ + caf_roots, /* Number of CAFs */ + bstk_roots; /* Number of update frames in B stack */ + + SAVE_REGS(&ScavRegDump); /* Save registers */ + +#if defined(LIFE_PROFILE) + if (do_life_prof) { life_profile_setup(); } +#endif /* LIFE_PROFILE */ + +#if defined(USE_COST_CENTRES) + if (interval_expired) { heap_profile_setup(); } +#endif /* USE_COST_CENTRES */ + + if (SM_trace) + fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n", + appelInfo.semi_space, + (W_) appelInfo.space[appelInfo.semi_space].base, + (W_) appelInfo.space[appelInfo.semi_space].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_))); + + alloc = sm->hp - hp_start; + stat_startGC(alloc); + + appelInfo.semi_space = NEXT_SEMI_SPACE(appelInfo.semi_space); + ToHp = appelInfo.space[appelInfo.semi_space].base - 1; + Scav = appelInfo.space[appelInfo.semi_space].base; + OldGen = sm->OldLim; /* always evac ! */ + + SetCAFInfoTables( sm->CAFlist ); +#ifdef PAR + EvacuateLocalGAs(rtsTrue); +#else + evacSPTable( sm ); +#endif /* PAR */ + EvacuateRoots( sm->roots, sm->rootno ); +#ifdef CONCURRENT + EvacuateSparks(); +#endif +#ifndef PAR + EvacuateAStack( MAIN_SpA, stackInfo.botA ); + EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots ); +#endif /* !PAR */ + + Scavenge(); + + EvacAndScavengeCAFs( sm->CAFlist, &extra_caf_words, &caf_roots ); + +#ifdef PAR + RebuildGAtables(rtsTrue); +#else + reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); +#endif /* PAR */ + + /* TIDY UP AND RETURN */ + + sm->hp = hp_start = ToHp; /* Last allocated word */ + + resident = sm->hp - (appelInfo.space[appelInfo.semi_space].base - 1); + DO_MAX_RESIDENCY(resident); /* stats only */ + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + if (sm->hplim > appelInfo.space[appelInfo.semi_space].lim) { + free_space = 0; + } else { + free_space = SM_alloc_size; + } + } else { + sm->hplim = appelInfo.space[appelInfo.semi_space].lim; + free_space = sm->hplim - sm->hp; + } + +#if defined(FORCE_GC) + if (force_GC && (sm->hplim > sm->hp + GCInterval)) { + sm->hplim = sm->hp + GCInterval; + } +#endif /* FORCE_GC */ + + if (SM_stats_verbose) { + char comment_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s", + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, + caf_roots, extra_caf_words*sizeof(W_), + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_), + (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_)); +#else + /* ToDo: come up with some interesting statistics for the parallel world */ + sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s", + 0, 0L, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0L, 0L); + +#endif + +#if defined(LIFE_PROFILE) + if (do_life_prof) { + strcat(comment_str, " life"); + } +#endif +#if defined(USE_COST_CENTRES) + if (interval_expired) { + strcat(comment_str, " prof"); + } +#endif + + stat_endGC(alloc, SM_word_heap_size, resident, comment_str); + } else { + stat_endGC(alloc, SM_word_heap_size, resident, ""); + } + +#if defined(LIFE_PROFILE) + free_space = free_space / 2; /* space for HpLim incr */ + if (do_life_prof) { + next_interval = life_profile_done(alloc, reqsize); + free_space -= next_interval; /* ensure interval available */ + } +#endif /* LIFE_PROFILE */ + +#if defined(USE_COST_CENTRES) || defined(GUM) + if (interval_expired) { +# if defined(USE_COST_CENTRES) + heap_profile_done(); +# endif + report_cc_profiling(0 /*partial*/); + } +#endif /* USE_COST_CENTRES */ + + if (SM_trace) + fprintf(stderr, "Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + appelInfo.semi_space, + (W_) appelInfo.space[appelInfo.semi_space].base, + (W_) appelInfo.space[appelInfo.semi_space].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_))); + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating, and all of the space + we just came from. */ + { + I_ old_space = NEXT_SEMI_SPACE(appelInfo.semi_space); + TrashMem(appelInfo.space[old_space].base, appelInfo.space[old_space].lim); + TrashMem(sm->hp+1, sm->hplim); + } +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + if ( (SM_alloc_min > free_space) || (reqsize > free_space) ) { + return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */ + } else { + +#if defined(LIFE_PROFILE) + /* ToDo: this may not be right now (WDP 94/11) */ + + /* space for HpLim incr */ + sm->hplim = sm->hp + ((sm->hplim - sm->hp) / 2); + if (do_life_prof) { + /* set hplim for next life profile */ + sm->hplim = sm->hp + next_interval; + } +#endif /* LIFE_PROFILE */ + + if (reqsize + sm->hardHpOverflowSize > free_space) { + return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */ + } else { + return( GC_SUCCESS ); /* Heap OK */ + } + } +} + + +I_ +collectHeap(reqsize, sm, do_full_collection) + W_ reqsize; + smInfo *sm; + rtsBool do_full_collection; /* do a major collection regardless? */ +{ + I_ bstk_roots, caf_roots, mutable, old_words; + P_ oldptr, old_start, mutptr, prevmut; + P_ CAFptr, prevCAF; + P_ next; + + I_ alloc, /* Number of words allocated since last GC */ + resident; /* Number of words remaining after GC */ + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ + I_ promote, /* Promoted this minor collection */ + dead_prom, /* Dead words promoted this minor */ + dead_prev; /* Promoted words that died since previos minor collection */ + I_ root; + P_ base[2]; +#endif /* PROMOTION_DATA */ + + fflush(stdout); /* Flush stdout at start of GC */ + + if (SM_force_gc == USE_2s) { + return collect2s(reqsize, sm); + } + + SAVE_REGS(&ScavRegDump); /* Save registers */ + + if (SM_trace) + fprintf(stderr, "Start: newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n", + (W_) appelInfo.newbase, (W_) appelInfo.newlim, (W_) sm->hp, (W_) sm->hplim, reqsize * sizeof(W_)); + + alloc = sm->hp - hp_start; + stat_startGC(alloc); + +#ifdef FORCE_GC + alloc_since_last_major_GC += sm->hplim - hp_start; + /* this is indeed supposed to be less precise than alloc above */ +#endif /* FORCE_GC */ + + /* COPYING COLLECTION */ + + /* Set ToHp to end of old gen */ + ToHp = appelInfo.oldlim; + + /* Set OldGen register so we only evacuate new gen closures */ + OldGen = appelInfo.oldlim; + + /* FIRST: Evacuate and Scavenge CAFs and roots in the old generation */ + old_start = ToHp; + + SetCAFInfoTables( sm->CAFlist ); + + DEBUG_STRING("Evacuate CAFs:"); + caf_roots = 0; + CAFptr = sm->CAFlist; + prevCAF = ((P_)(&sm->CAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */ + while (CAFptr) { + EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */ + caf_roots++; + prevCAF = CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr); + } + IND_CLOSURE_LINK(prevCAF) = (W_) appelInfo.OldCAFlist; + appelInfo.OldCAFlist = sm->CAFlist; + appelInfo.OldCAFno += caf_roots; + sm->CAFlist = NULL; + + DEBUG_STRING("Evacuate Mutable Roots:"); + mutable = 0; + mutptr = sm->OldMutables; + /* Clever, but completely illegal: */ + prevmut = ((P_)&sm->OldMutables) - FIXED_HS; + /* See MUT_LINK */ + while ( mutptr ) { + + /* Scavenge the OldMutable */ + P_ info = (P_) INFO_PTR(mutptr); + StgScavPtr scav_code = SCAV_CODE(info); + Scav = mutptr; + (scav_code)(); + + /* Remove from OldMutables if no longer mutable */ + if (!IS_MUTABLE(info)) { + P_ tmp = mutptr; + MUT_LINK(prevmut) = MUT_LINK(mutptr); + mutptr = (P_) MUT_LINK(mutptr); + MUT_LINK(tmp) = MUT_NOT_LINKED; + } else { + prevmut = mutptr; + mutptr = (P_) MUT_LINK(mutptr); + } + mutable++; + } + +#ifdef PAR + EvacuateLocalGAs(rtsFalse); +#else + evacSPTable( sm ); +#endif /* PAR */ + + DEBUG_STRING("Scavenge evacuated old generation roots:"); + + Scav = appelInfo.oldlim + 1; /* Point to (info field of) first closure */ + + Scavenge(); + + old_words = ToHp - old_start; + + /* PROMOTE closures rooted in the old generation and reset list of old gen roots */ + + appelInfo.oldlim = ToHp; + + /* SECOND: Evacuate and scavenge remaining roots + These may already have been evacuated -- just get new address + */ + + EvacuateRoots( sm->roots, sm->rootno ); + +#ifdef CONCURRENT + EvacuateSparks(); +#endif +#ifndef PAR + EvacuateAStack( MAIN_SpA, stackInfo.botA ); + EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots ); + /* ToDo: Optimisation which squeezes out garbage update frames */ +#endif /* PAR */ + + Scav = appelInfo.oldlim + 1; /* Point to (info field of) first closure */ + + Scavenge(); + + appelInfo.oldlim = ToHp; + + /* record newly promoted mutuple roots */ + MUT_LINK(prevmut) = (W_) appelInfo.PromMutables; + appelInfo.PromMutables = 0; + + /* set new generation base, if not fixed */ + if (! appelInfo.newfixed) { + appelInfo.newbase = appelInfo.oldlim + 1 + (((appelInfo.newlim - appelInfo.oldlim) + 1) / 2); + } + +#ifdef PAR + RebuildGAtables(rtsFalse); +#else + reportDeadMallocPtrs(sm->MallocPtrList, + sm->OldMallocPtrList, + &(sm->OldMallocPtrList)); + sm->MallocPtrList = NULL; /* all (new) MallocPtrs have been promoted */ +#endif /* PAR */ + + resident = appelInfo.oldlim - sm->OldLim; + /* DONT_DO_MAX_RESIDENCY -- it is just a minor collection */ + + if (SM_stats_verbose) { + char minor_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(minor_str, "%4u %4ld %3ld %3ld %4ld Minor", + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, caf_roots, mutable); /* oldnew_roots, old_words */ +#else + /* ToDo: come up with some interesting statistics for the parallel world */ + sprintf(minor_str, "%4u %4ld %3ld %3ld %4ld Minor", + 0, 0L, sm->rootno, caf_roots, mutable); +#endif + stat_endGC(alloc, alloc, resident, minor_str); + } else { + stat_endGC(alloc, alloc, resident, ""); + } + + /* Note: if do_full_collection we want to force a full collection. [ADR] */ + +#ifdef FORCE_GC + if (force_GC && (alloc_since_last_major_GC >= GCInterval)) { + do_full_collection = 1; + } +#endif /* FORCE_GC */ + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data major required */ + + if (! SM_stats_verbose && + (appelInfo.oldlim < appelInfo.oldthresh) && + (reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) && + (! do_full_collection) ) { + +#else /* ! PROMOTION_DATA */ + + if ((appelInfo.oldlim < appelInfo.oldthresh) && + (reqsize + sm->hardHpOverflowSize <= appelInfo.newlim - appelInfo.newbase) && + (! do_full_collection) ) { + +#endif /* ! PROMOTION_DATA */ + + sm->hp = hp_start = appelInfo.newbase - 1; + sm->hplim = appelInfo.newlim; + +#if defined(FORCE_GC) + if (force_GC && + (alloc_since_last_major_GC + (sm->hplim - hp_start) > GCInterval)) + { + sm->hplim = sm->hp + (GCInterval - alloc_since_last_major_GC); + } +#endif /* FORCE_GC */ + + sm->OldLim = appelInfo.oldlim; + + if (SM_trace) { + fprintf(stderr, "Minor: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) appelInfo.newbase, (W_) appelInfo.newlim, + (W_) appelInfo.oldbase, (W_) appelInfo.oldlim, + (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + } + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating. */ + TrashMem(sm->hp+1, sm->hplim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + return GC_SUCCESS; /* Heap OK -- Enough space to continue */ + } + + DEBUG_STRING("Major Collection Required"); + +#ifdef FORCE_GC + alloc_since_last_major_GC = 0; +#endif /* FORCE_GC */ + + stat_startGC(0); + + alloc = (appelInfo.oldlim - appelInfo.oldbase) + 1; + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ + if (SM_stats_verbose) { + promote = appelInfo.oldlim - thisbase + 1; + } +#endif /* PROMOTION_DATA */ + + appelInfo.bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + appelInfo.bits = (BitWord *)(appelInfo.newlim) - appelInfo.bit_words; + /* For some reason, this doesn't seem to use the last + allocatable word at appelInfo.newlim */ + + if (appelInfo.bits <= appelInfo.oldlim) { + fprintf(stderr, "APPEL Major: Not enough space for bit vector\n"); + return GC_HARD_LIMIT_EXCEEDED; + } + + /* Zero bit vector for marking phase of major collection */ + { BitWord *ptr = appelInfo.bits, + *end = appelInfo.bits + appelInfo.bit_words; + while (ptr < end) { *(ptr++) = 0; }; + } + +#ifdef HAVE_VADVISE + vadvise(VA_ANOM); +#endif + + /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */ + RESTORE_REGS(&ScavRegDump); + + markHeapRoots(sm, + appelInfo.OldCAFlist, + NULL, + appelInfo.oldbase, + appelInfo.oldlim, + appelInfo.bits); + + SAVE_REGS(&ScavRegDump); + /* end of bracket */ + +#ifndef PAR + sweepUpDeadMallocPtrs(sm->OldMallocPtrList, + appelInfo.oldbase, + appelInfo.bits + ); +#endif /* !PAR */ + + /* Reset OldMutables -- this will be reconstructed during scan */ + sm->OldMutables = 0; + + LinkCAFs(appelInfo.OldCAFlist); + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ + /* What does this have to do with CAFs? -- JSM */ + if (SM_stats_verbose) { + base[0] = thisbase; + base[1] = prevbase; + + if (SM_trace) { + fprintf(stderr, "Promote Bases: lim 0x%lx this 0x%lx prev 0x%lx Actual: ", + appelInfo.oldlim + 1, thisbase, prevbase); + } + + /* search for first live closure for thisbase & prevbase */ + for (root = 0; root < 2; root++) { + P_ baseptr, search, scan_w_start; + I_ prev_words, bit_words, bit_rem; + BitWord *bit_array_ptr, *bit_array_end; + + baseptr = base[root]; + prev_words = (baseptr - appelInfo.oldbase); + bit_words = prev_words / BITS_IN(BitWord); + bit_rem = prev_words & (BITS_IN(BitWord) - 1); + + bit_array_ptr = appelInfo.bits + bit_words; + bit_array_end = appelInfo.bits + appelInfo.bit_words; + scan_w_start = baseptr - bit_rem; + + baseptr = 0; + while (bit_array_ptr < bit_array_end && !baseptr) { + BitWord w = *(bit_array_ptr++); + search = scan_w_start; + if (bit_rem) { + search += bit_rem; + w >>= bit_rem; + bit_rem = 0; + } + while (w && !baseptr) { + if (w & 0x1) { /* bit set -- found first closure */ + baseptr = search; + } else { + search++; /* look at next bit */ + w >>= 1; + } + } + scan_w_start += BITS_IN(BitWord); + } + if (SM_trace) { + fprintf(stderr, "0x%lx%s", baseptr, root == 2 ? "\n" : " "); + } + + base[root] = baseptr; + if (baseptr) { + LINK_LOCATION_TO_CLOSURE(base + root); + } + } + } +#endif /* PROMOTION_DATA */ + + LinkRoots( sm->roots, sm->rootno ); +#ifdef CONCURRENT + LinkSparks(); +#endif +#ifdef PAR + LinkLiveGAs(appelInfo.oldbase, appelInfo.bits); +#else + DEBUG_STRING("Linking Stable Pointer Table:"); + LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable); + LinkAStack( MAIN_SpA, stackInfo.botA ); + LinkBStack( MAIN_SuB, stackInfo.botB ); +#endif + + /* Do Inplace Compaction */ + /* Returns start of next closure, -1 gives last allocated word */ + + appelInfo.oldlim = Inplace_Compaction(appelInfo.oldbase, + appelInfo.oldlim, + 0, 0, + appelInfo.bits, + appelInfo.bit_words +#ifndef PAR + ,&(sm->OldMallocPtrList) +#endif + ) - 1; + + appelInfo.oldlast = appelInfo.oldlim; + resident = (appelInfo.oldlim - appelInfo.oldbase) + 1; + DO_MAX_RESIDENCY(resident); /* stats only */ + + /* set new generation base, if not fixed */ + if (! appelInfo.newfixed) { + appelInfo.newbase = appelInfo.oldlim + 1 + (((appelInfo.newlim - appelInfo.oldlim) + 1) / 2); + } + + /* set major threshold, if not fixed */ + /* next major collection when old gen occupies 2/3rds of the free space or exceeds oldmax */ + if (! SM_major_gen_size) { + appelInfo.oldthresh = appelInfo.oldlim + (appelInfo.newlim - appelInfo.oldlim) * 2 / 3; + if (appelInfo.oldthresh > appelInfo.oldmax) + appelInfo.oldthresh = appelInfo.oldmax; + } + + sm->hp = hp_start = appelInfo.newbase - 1; + sm->hplim = appelInfo.newlim; + +#if defined(FORCE_GC) + if (force_GC && (sm->hplim > sm->hp + GCInterval)) { + sm->hplim = sm->hp + GCInterval; + } +#endif /* FORCE_GC */ + + sm->OldLim = appelInfo.oldlim; + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ + if (SM_stats_verbose) { + /* restore moved thisbase & prevbase */ + thisbase = base[0] ? base[0] : appelInfo.oldlim + 1; + prevbase = base[1] ? base[1] : appelInfo.oldlim + 1; + + /* here are the numbers we want */ + dead_prom = promote - (appelInfo.oldlim + 1 - thisbase); + dead_prev = prev_prom - (thisbase - prevbase) - dead_prev_prom; + + if (SM_trace) { + fprintf(stderr, "Collect Bases: lim 0x%lx this 0x%lx prev 0x%lx\n", + appelInfo.oldlim + 1, thisbase, prevbase); + fprintf(stderr, "Promoted: %ld Dead: this %ld prev %ld + %ld\n", + promote, dead_prom, dead_prev_prom, dead_prev); + } + + /* save values for next collection */ + prev_prom = promote; + dead_prev_prom = dead_prom; + prevbase = thisbase; + thisbase = appelInfo.oldlim + 1; + } +#endif /* PROMOTION_DATA */ + +#ifdef HAVE_VADVISE + vadvise(VA_NORM); +#endif + + if (SM_stats_verbose) { + char major_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(major_str, "%4u %4ld %3ld %3ld %4d %4d *Major* %4.1f%%", + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, appelInfo.OldCAFno, + 0, 0, resident / (StgFloat) SM_word_heap_size * 100); +#else + /* ToDo: come up with some interesting statistics for the parallel world */ + sprintf(major_str, "%4u %4ld %3ld %3ld %4d %4d *Major* %4.1f%%", + 0, 0L, sm->rootno, appelInfo.OldCAFno, 0, 0, + resident / (StgFloat) SM_word_heap_size * 100); +#endif + +#if defined(PROMOTION_DATA) /* For dead promote & premature promote data */ + { char *promote_str[BIG_STRING_LEN]; + sprintf(promote_str, " %6ld %6ld", dead_prom*sizeof(W_), dead_prev*sizeof(W_)); + strcat(major_str, promote_str); + } +#endif /* PROMOTION_DATA */ + + stat_endGC(0, alloc, resident, major_str); + } else { + stat_endGC(0, alloc, resident, ""); + } + + if (SM_trace) { + fprintf(stderr, "Major: newbase 0x%lx newlim 0x%lx; base 0x%lx lim 0x%lx thresh 0x%lx max 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) appelInfo.newbase, (W_) appelInfo.newlim, + (W_) appelInfo.oldbase, (W_) appelInfo.oldlim, + (W_) appelInfo.oldthresh, (W_) appelInfo.oldmax, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + } + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating. */ + TrashMem(sm->hp+1, sm->hplim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + if ((appelInfo.oldlim > appelInfo.oldmax) + || (reqsize > sm->hplim - sm->hp) ) { + return( GC_HARD_LIMIT_EXCEEDED ); /* Heap absolutely exhausted */ + } else if (reqsize + sm->hardHpOverflowSize > sm->hplim - sm->hp) { + return( GC_SOFT_LIMIT_EXCEEDED ); /* Heap nearly exhausted */ + } else { + return( GC_SUCCESS ); /* Heap OK */ + } +} + +#endif /* GCap */ + +\end{code} diff --git a/ghc/runtime/storage/SMcheck.lc b/ghc/runtime/storage/SMcheck.lc new file mode 100644 index 0000000000..1318021f97 --- /dev/null +++ b/ghc/runtime/storage/SMcheck.lc @@ -0,0 +1,127 @@ +\section[storage-manager-check]{Checking Consistency of Storage Manager} + +This code performs consistency/sanity checks on the stacks and heap. +It can be called each time round the mini-interpreter loop. Not +required if we're tail-jumping (no mini-interpreter). + +\begin{code} + +#if ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) ) + +/* Insist on the declaration of STG-machine registers */ +#define MAIN_REG_MAP + +#include "SMinternal.h" + +#define isHeapPtr(p) \ + ((p) >= heap_space && (p) < heap_space + SM_word_heap_size) + +#if nextstep2_TARGET_OS || nextstep3_TARGET_OS /* ToDo: use END_BY_FUNNY_MEANS or something */ +#define validInfoPtr(i) \ + ((i) < (StgPtr) (get_end_result) /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */) + /* No Internal info tables allowed (type -1) */ + +#else /* non-NeXT */ +#define validInfoPtr(i) \ + ((i) < (P_) &end /* && MIN_INFO_TYPE < INFO_TYPE(i) && INFO_TYPE(i) < MAX_INFO_TYPE */) + /* No Internal info tables allowed (type -1) */ + +#endif /* non-NeXT */ + +#define suspectPtr(p) ((p) < (P_)256) + +#if defined(GC2s) +#define validHeapPtr(p) \ + ((p) >= semispaceInfo[semispace].base && (p) <= semispaceInfo[semispace].lim) +#else +#if defined(GC1s) +#define validHeapPtr(p) \ + ((p) >= compactingInfo.base && (p) <= compactingInfo.lim) +#else +#if defined(GCdu) +#define validHeapPtr(p) \ + ((p) >= dualmodeInfo.modeinfo[dualmodeInfo.mode].base && \ + (p) <= dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) + +#else +#if defined(GCap) +/* Two cases needed, depending on whether the 2-space GC is forced + SLPJ 17 June 93 */ +#define validHeapPtr(p) \ + (SM_force_gc == USE_2s ? \ + ((p) >= appelInfo.space[appelInfo.semi_space].base && \ + (p) <= appelInfo.space[appelInfo.semi_space].lim) : \ + (((p) >= appelInfo.oldbase && (p) <= appelInfo.oldlim) || \ + ((p) >= appelInfo.newbase && (p) <= appelInfo.newlim)) \ + ) + +#else +#if defined(GCgn) +#define validHeapPtr(p) \ + (((p) >= genInfo.oldbase && (p) <= genInfo.oldlim) || \ + ((p) >= genInfo.newgen[genInfo.curnew].newbase && (p) <= genInfo.newgen[genInfo.curnew].newlim) || \ + ((p) >= genInfo.allocbase && (p) <= genInfo.alloclim)) +#else +#define validHeapPtr(p) 0 +#endif +#endif +#endif +#endif +#endif + + +void checkAStack(STG_NO_ARGS) +{ + PP_ stackptr; + P_ closurePtr; + P_ infoPtr; + I_ error = 0; + + if (SuB > SpB + 1) { + fprintf(stderr, "SuB (%lx) > SpB (%lx)\n", (W_) SuB, (W_) SpB); + error = 1; + } + if (SuA < SpA) { + fprintf(stderr, "SuA (%lx) < SpA (%lx)\n", (W_) SuA, (W_) SpA); + error = 1; + } + + for (stackptr = SpA; + SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0; + stackptr = stackptr + AREL(1)) { + + closurePtr = (P_) *stackptr; + + if (suspectPtr(closurePtr)) { + fprintf(stderr, "Suspect heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n", + (W_) SpA, (W_) stackptr, (W_) closurePtr); + error = 1; + + } else if (isHeapPtr(closurePtr) && ! validHeapPtr(closurePtr)) { + + fprintf(stderr, "Bad heap ptr on A stk; SpA %lx, sp %lx, ptr %lx\n", + (W_) SpA, (W_) stackptr, (W_) closurePtr); + error = 1; + + } else { + infoPtr = (P_) *closurePtr; + + if (suspectPtr(infoPtr)) { + fprintf(stderr, "Suspect info ptr on A stk; SpA %lx, sp %lx, closure %lx info %lx\n", + (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr); + error = 1; + + } else if ( ! validInfoPtr(infoPtr)) { + fprintf(stderr, "Bad info ptr in A stk; SpA %lx, sp %lx, closure %lx, info %lx\n", + (W_) SpA, (W_) stackptr, (W_) closurePtr, (W_) infoPtr/* , INFO_TYPE(infoPtr) */); + error = 1; + } + } + } + + if (error) abort(); +} + +#endif /* ! ( defined(__STG_TAILJUMPS__) && defined(__GNUC__) ) */ + +\end{code} diff --git a/ghc/runtime/storage/SMcompacting.h b/ghc/runtime/storage/SMcompacting.h new file mode 100644 index 0000000000..e64b8fd5bb --- /dev/null +++ b/ghc/runtime/storage/SMcompacting.h @@ -0,0 +1,7 @@ +# line 4 "storage/SMcompacting.lh" +extern void LinkRoots PROTO((P_ roots[], I_ rootno)); +extern void LinkAStack PROTO((PP_ stackA, PP_ botA)); +extern void LinkBStack PROTO((P_ stackB, P_ botB)); +extern I_ CountCAFs PROTO((P_ CAFlist)); + +extern void LinkCAFs PROTO((P_ CAFlist)); diff --git a/ghc/runtime/storage/SMcompacting.lc b/ghc/runtime/storage/SMcompacting.lc new file mode 100644 index 0000000000..60942d3b41 --- /dev/null +++ b/ghc/runtime/storage/SMcompacting.lc @@ -0,0 +1,234 @@ +\section[SM-compacting]{Compacting Collector Subroutines} + +This is a collection of C functions used in implementing the compacting +collectors. + +The motivation for making this a separate file/section is twofold: + +1) It lets us focus on one thing. + +2) If we don't do this, there will be a huge amount of repetition + between the various GC schemes --- a maintenance nightmare. + +The second is the major motivation. + +ToDo ADR: trash contents of other semispace after GC in debugging version + +\begin{code} +#if defined(GC1s) || defined(GCdu) || defined(GCap) || defined(GCgn) + /* to the end */ + +#if defined(GC1s) + +#define SCAN_REG_DUMP +#include "SMinternal.h" +REGDUMP(ScanRegDump); + +#else /* GCdu, GCap, GCgn */ + +#define SCAV_REG_MAP +#include "SMinternal.h" +REGDUMP(ScavRegDump); + +#endif + +#include "SMcompacting.h" +\end{code} + +\begin{code} +void +LinkRoots(roots, rootno) +P_ roots[]; +I_ rootno; +{ + I_ root; + + DEBUG_STRING("Linking Roots:"); + for (root = 0; root < rootno; root++) { + LINK_LOCATION_TO_CLOSURE(&(roots[root])); + } +} + +\end{code} + +\begin{code} + +#ifdef CONCURRENT +void +LinkSparks(STG_NO_ARGS) +{ + PP_ sparkptr; + int pool; + + DEBUG_STRING("Linking Sparks:"); + for (pool = 0; pool < SPARK_POOLS; pool++) { + for (sparkptr = PendingSparksHd[pool]; + sparkptr < PendingSparksTl[pool]; sparkptr++) { + LINK_LOCATION_TO_CLOSURE(sparkptr); + } + } +} +#endif + +\end{code} + +\begin{code} + +#ifdef PAR + +void +LinkLiveGAs(base, bits) +P_ base; +BitWord *bits; +{ + GALA *gala; + GALA *next; + GALA *prev; + long _hp_word, bit_index, bit; + + DEBUG_STRING("Linking Live GAs:"); + + for (gala = liveIndirections, prev = NULL; gala != NULL; gala = next) { + next = gala->next; + ASSERT(gala->ga.loc.gc.gtid == mytid); + if (gala->ga.weight != MAX_GA_WEIGHT) { + LINK_LOCATION_TO_CLOSURE(&gala->la); + gala->next = prev; + prev = gala; + } else { + /* Since we have all of the weight, this GA is no longer needed */ + W_ pga = PACK_GA(thisPE, gala->ga.loc.gc.slot); + +#ifdef FREE_DEBUG + fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot); +#endif + gala->next = freeIndirections; + freeIndirections->next = gala; + (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala); +#ifdef DEBUG + gala->ga.weight = 0x0d0d0d0d; + gala->la = (P_) 0xbadbad; +#endif + } + } + liveIndirections = prev; + + prepareFreeMsgBuffers(); + + for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) { + next = gala->next; + ASSERT(gala->ga.loc.gc.gtid != mytid); + + _hp_word = gala->la - base; + bit_index = _hp_word / BITS_IN(BitWord); + bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1)); + if (!(bits[bit_index] & bit)) { + int pe = taskIDtoPE(gala->ga.loc.gc.gtid); + W_ pga = PACK_GA(pe, gala->ga.loc.gc.slot); + int i; + + (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala); + freeRemoteGA(pe, &(gala->ga)); + gala->next = freeGALAList; + freeGALAList = gala; + } else { + LINK_LOCATION_TO_CLOSURE(&gala->la); + gala->next = prev; + prev = gala; + } + } + liveRemoteGAs = prev; + + /* If we have any remaining FREE messages to send off, do so now */ + sendFreeMessages(); +} + +#else + +\end{code} + +Note: no \tr{Link[AB]Stack} for ``parallel'' systems, because they +don't have a single main stack. + +\begin{code} + +void +LinkAStack(stackA, botA) +PP_ stackA; +PP_ botA; +{ + PP_ stackptr; + + DEBUG_STRING("Linking A Stack:"); + for (stackptr = stackA; + SUBTRACT_A_STK(stackptr, botA) >= 0; + stackptr = stackptr + AREL(1)) { + LINK_LOCATION_TO_CLOSURE(stackptr); + } +} +#endif /* PAR */ +\end{code} + +ToDo (Patrick?): Dont explicitly mark & compact unmarked Bstack frames + +\begin{code} +#if ! defined(PAR) +void +LinkBStack(stackB, botB) +P_ stackB; +P_ botB; /* stackB points to topmost update frame */ +{ + P_ updateFramePtr; + + DEBUG_STRING("Linking B Stack:"); + for (updateFramePtr = stackB; + SUBTRACT_B_STK(updateFramePtr, botB) > 0; + /* re-initialiser given explicitly */ ) { + + P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE); + + LINK_LOCATION_TO_CLOSURE(updateClosurePtr); + + updateFramePtr = GRAB_SuB(updateFramePtr); + } +} +#endif /* not PAR */ +\end{code} + +\begin{code} +I_ +CountCAFs(CAFlist) +P_ CAFlist; +{ + I_ caf_no = 0; + + for (caf_no = 0; CAFlist != NULL; CAFlist = (P_) IND_CLOSURE_LINK(CAFlist)) + caf_no++; + + return caf_no; +} +\end{code} + +\begin{code} +void +LinkCAFs(CAFlist) +P_ CAFlist; +{ + DEBUG_STRING("Linking CAF Ptr Locations:"); + while(CAFlist != NULL) { + DEBUG_LINK_CAF(CAFlist); + LINK_LOCATION_TO_CLOSURE(&IND_CLOSURE_PTR(CAFlist)); + CAFlist = (P_) IND_CLOSURE_LINK(CAFlist); + } +} + +\end{code} + +\begin{code} + +#ifdef PAR + +#endif /* PAR */ + +#endif /* defined(_INFO_COMPACTING) */ +\end{code} diff --git a/ghc/runtime/storage/SMcompacting.lh b/ghc/runtime/storage/SMcompacting.lh new file mode 100644 index 0000000000..8740253057 --- /dev/null +++ b/ghc/runtime/storage/SMcompacting.lh @@ -0,0 +1,11 @@ +\section[SMcompacting-header]{Header file for SMcompacting} + +\begin{code} +extern void LinkRoots PROTO((P_ roots[], I_ rootno)); +extern void LinkAStack PROTO((PP_ stackA, PP_ botA)); +extern void LinkBStack PROTO((P_ stackB, P_ botB)); +extern I_ CountCAFs PROTO((P_ CAFlist)); + +extern void LinkCAFs PROTO((P_ CAFlist)); +\end{code} + diff --git a/ghc/runtime/storage/SMcopying.lc b/ghc/runtime/storage/SMcopying.lc new file mode 100644 index 0000000000..98b1b79a8d --- /dev/null +++ b/ghc/runtime/storage/SMcopying.lc @@ -0,0 +1,363 @@ +\section[SM-copying]{Copying Collector Subroutines} + +This is a collection of C functions used in implementing the copying +collectors. + +The motivation for making this a separate file/section is twofold: + +1) It lets us focus on one thing. + +2) If we don't do this, there will be a huge amount of repetition + between the various GC schemes --- a maintenance nightmare. + +The second is the major motivation. + + +\begin{code} +#if defined(GC2s) || defined(GCdu) || defined(GCap) || defined(GCgn) + /* to the end */ + +#define SCAV_REG_MAP +#include "SMinternal.h" +REGDUMP(ScavRegDump); + +#include "SMcopying.h" +\end{code} + +Comment stolen from SMscav.lc: When doing a new generation copy +collection for Appel's collector only evacuate references that point +to the new generation. OldGen must be set to point to the end of old +space. + +\begin{code} +#ifdef GCap + +#define MAYBE_EVACUATE_CLOSURE( closure ) \ +do { \ + P_ evac = (P_) (closure); \ + if (evac > OldGen) { \ + (closure) = EVACUATE_CLOSURE(evac); \ + } \ +} while (0) + +#else + +#define MAYBE_EVACUATE_CLOSURE( closure ) \ +do { \ + P_ evac = (P_) (closure); \ + (closure) = EVACUATE_CLOSURE(evac); \ +} while (0) + +#endif +\end{code} + +\begin{code} +void +SetCAFInfoTables( CAFlist ) + P_ CAFlist; +{ + P_ CAFptr; + + /* Set CAF info tables for evacuation */ + DEBUG_STRING("Setting Evac & Upd CAFs:"); + for (CAFptr = CAFlist; + CAFptr != NULL; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr) ) { + INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info; + } +} +\end{code} + +\begin{code} +void +EvacuateRoots( roots, rootno ) + P_ roots[]; + I_ rootno; +{ + I_ root; + + DEBUG_STRING("Evacuate (Reg) Roots:"); + for (root = 0; root < rootno; root++) { + MAYBE_EVACUATE_CLOSURE( roots[root] ); + } +} +\end{code} + +\begin{code} +#ifdef CONCURRENT +void +EvacuateSparks(STG_NO_ARGS) +{ + PP_ sparkptr; + int pool; + + + DEBUG_STRING("Evacuate Sparks:"); + for (pool = 0; pool < SPARK_POOLS; pool++) { + for (sparkptr = PendingSparksHd[pool]; + sparkptr < PendingSparksTl[pool]; sparkptr++) { + MAYBE_EVACUATE_CLOSURE(*((PP_) sparkptr)); + } + } +} +#endif +\end{code} + +Note: no \tr{evacuate[AB]Stack} for ``parallel'' systems, because they +don't have a single main stack. + +\begin{code} +#ifndef PAR +void +EvacuateAStack( stackA, botA ) + PP_ stackA; + PP_ botA; /* botA points to bottom-most word */ +{ + PP_ stackptr; + + DEBUG_STRING("Evacuate A Stack:"); + for (stackptr = stackA; + SUBTRACT_A_STK(stackptr, botA) >= 0; + stackptr = stackptr + AREL(1)) { + MAYBE_EVACUATE_CLOSURE( *((PP_) stackptr) ); + } +} +#endif /* not PAR */ +\end{code} + +ToDo: Optimisation which squeezes out update frames which point to +garbage closures. + +Perform collection first + +Then process B stack removing update frames (bot to top via pointer +reversal) that reference garbage closues (test infoptr != +EVACUATED_INFOPTR) + +Otherwise closure is live update reference to to-space address + +\begin{code} +#ifndef PAR +void +EvacuateBStack( stackB, botB, roots ) + P_ stackB; + P_ botB; /* botB points to bottom-most word */ + I_ *roots; +{ + I_ bstk_roots; + P_ updateFramePtr; + P_ updatee; + + DEBUG_STRING("Evacuate B Stack:"); + bstk_roots = 0; + for (updateFramePtr = stackB; /* stackB points to topmost update frame */ + SUBTRACT_B_STK(updateFramePtr, botB) > 0; + updateFramePtr = GRAB_SuB(updateFramePtr)) { + + /* Evacuate the thing to be updated */ + updatee = GRAB_UPDATEE(updateFramePtr); + MAYBE_EVACUATE_CLOSURE(updatee); + PUSH_UPDATEE(updateFramePtr, updatee); + bstk_roots++; + } + *roots = bstk_roots; +} +#endif /* not PAR */ +\end{code} + +When we do a copying collection, we want to evacuate all of the local entries +in the GALA table for which there are outstanding remote pointers (i.e. for +which the weight is not MAX_GA_WEIGHT.) + +\begin{code} + +#ifdef PAR + +void +EvacuateLocalGAs(full) +rtsBool full; +{ + GALA *gala; + GALA *next; + GALA *prev = NULL; + + for (gala = liveIndirections; gala != NULL; gala = next) { + next = gala->next; + ASSERT(gala->ga.loc.gc.gtid == mytid); + if (gala->ga.weight != MAX_GA_WEIGHT) { + /* Remote references exist, so we must evacuate the local closure */ + P_ old = gala->la; + MAYBE_EVACUATE_CLOSURE(gala->la); + if (!full && gala->preferred && gala->la != old) { + (void) removeHashTable(LAtoGALAtable, (W_) old, (void *) gala); + insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala); + } + gala->next = prev; + prev = gala; + } else { + /* Since we have all of the weight, this GA is no longer needed */ + W_ pga = PACK_GA(thisPE, gala->ga.loc.gc.slot); + +#ifdef FREE_DEBUG + fprintf(stderr, "Freeing slot %d\n", gala->ga.loc.gc.slot); +#endif + gala->next = freeIndirections; + freeIndirections = gala; + (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala); + if (!full && gala->preferred) + (void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala); +#ifdef DEBUG + gala->ga.weight = 0x0d0d0d0d; + gala->la = (P_) 0xbadbad; +#endif + } + } + liveIndirections = prev; +} + +\end{code} + +\begin{code} + +EXTDATA_RO(Forward_Ref_info); + +void +RebuildGAtables(full) +rtsBool full; +{ + GALA *gala; + GALA *next; + GALA *prev; + P_ closure; + + prepareFreeMsgBuffers(); + + for (gala = liveRemoteGAs, prev = NULL; gala != NULL; gala = next) { + next = gala->next; + ASSERT(gala->ga.loc.gc.gtid != mytid); + + closure = gala->la; + + /* + * If the old closure has not been forwarded, we let go. Note that this + * approach also drops global aliases for PLCs. + */ + +#if defined(GCgn) || defined(GCap) + if (closure > OldGen) { +#endif + if (!full && gala->preferred) + (void) removeHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala); + + /* Follow indirection chains to the end, just in case */ + while (IS_INDIRECTION(INFO_PTR(closure))) + closure = (P_) IND_CLOSURE_PTR(closure); + + /* Change later to incorporate a _FO bit in the INFO_TYPE for GCgn */ +#ifdef GCgn + fall over, until _FO bits are added +#endif + if (INFO_PTR(closure) != (W_) Forward_Ref_info) { + int pe = taskIDtoPE(gala->ga.loc.gc.gtid); + W_ pga = PACK_GA(pe, gala->ga.loc.gc.slot); + int i; + + (void) removeHashTable(pGAtoGALAtable, pga, (void *) gala); + freeRemoteGA(pe, &(gala->ga)); + gala->next = freeGALAList; + freeGALAList = gala; + } else { + /* Find the new space object */ + closure = (P_) FORWARD_ADDRESS(closure); + gala->la = closure; + + if (!full && gala->preferred) + insertHashTable(LAtoGALAtable, (W_) gala->la, (void *) gala); + gala->next = prev; + prev = gala; + } +#if defined(GCgn) || defined(GCap) + } else { + /* Old generation, minor collection; just keep it */ + gala->next = prev; + prev = gala; + } +#endif + } + liveRemoteGAs = prev; + + /* If we have any remaining FREE messages to send off, do so now */ + sendFreeMessages(); + + if (full) + RebuildLAGAtable(); +} + +#endif + +\end{code} + +\begin{code} +void +Scavenge() +{ + DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp); + while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp); +} +\end{code} + +\begin{code} +#ifdef GCdu + +void +EvacuateCAFs( CAFlist ) + P_ CAFlist; +{ + P_ CAFptr; + + DEBUG_STRING("Evacuate CAFs:"); + for (CAFptr = CAFlist; + CAFptr != NULL; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */ + } +} + +/* ToDo: put GCap EvacuateCAFs code here */ + +#else /* not GCdu */ + +void +EvacAndScavengeCAFs( CAFlist, extra_words, roots ) + P_ CAFlist; + I_ *extra_words; + I_ *roots; +{ + I_ caf_roots = 0; + P_ caf_start = ToHp; + P_ CAFptr; + + DEBUG_STRING("Evacuate & Scavenge CAFs:"); + for (CAFptr = CAFlist; + CAFptr != NULL; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + + EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */ + caf_roots++; + + DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp); + while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp); + + /* this_extra_caf_words = ToHp - this_caf_start; */ + /* ToDo: Report individual CAF space */ + } + *extra_words = ToHp - caf_start; + *roots = caf_roots; +} + +#endif /* !GCdu */ + +#endif /* defined(_INFO_COPYING) */ +\end{code} diff --git a/ghc/runtime/storage/SMcopying.lh b/ghc/runtime/storage/SMcopying.lh new file mode 100644 index 0000000000..f2fbf140d7 --- /dev/null +++ b/ghc/runtime/storage/SMcopying.lh @@ -0,0 +1,15 @@ +\section[SMcopying-header]{Header file for SMcopying} + +\begin{code} +extern void SetCAFInfoTables PROTO(( P_ CAFlist )); +extern void EvacuateRoots PROTO(( P_ roots[], I_ rootno )); +extern void EvacuateAStack PROTO(( PP_ stackA, PP_ botA )); +extern void EvacuateBStack PROTO(( P_ stackB, P_ botB, I_ *roots )); +extern void Scavenge PROTO(()); + +#ifdef GCdu +extern void EvacuateCAFs PROTO(( P_ CAFlist )); +#else /* !GCdu */ +extern void EvacAndScavengeCAFs PROTO(( P_ CAFlist, I_ *extra_words, I_ *roots )); +#endif /* !GCdu */ +\end{code} diff --git a/ghc/runtime/storage/SMdu.lc b/ghc/runtime/storage/SMdu.lc new file mode 100644 index 0000000000..abd39230f6 --- /dev/null +++ b/ghc/runtime/storage/SMdu.lc @@ -0,0 +1,291 @@ +*************************************************************************** + + COMPACTING GARBAGE COLLECTION + +Global heap requirements as for 1s and 2s collectors. + +*************************************************************************** + +ToDo: soft heap limits. + +\begin{code} + +#if defined(GCdu) + +#define SCAV_REG_MAP +#include "SMinternal.h" +#include "SMcopying.h" +#include "SMcompacting.h" +#include "SMextn.h" + +REGDUMP(ScavRegDump); + +dualmodeData dualmodeInfo = {TWO_SPACE_BOT, + DEFAULT_RESID_TO_COMPACT, + DEFAULT_RESID_FROM_COMPACT, + {{0,0,0,"low->high"}, + {0,0,0,"high->low"}, + {0,0,0,"compacting"}}, + 0, 0 + }; + +P_ heap_space = 0; /* Address of first word of slab + of memory allocated for heap */ + +P_ hp_start; /* Value of Hp when reduction was resumed */ + +I_ +initHeap( sm ) + smInfo *sm; +{ + if (heap_space == 0) { /* allocates if it doesn't already exist */ + + I_ semispaceSize = SM_word_heap_size / 2; + + /* Allocate the roots space */ + sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) ); + + /* Allocate the heap */ + heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_)); + + dualmodeInfo.modeinfo[TWO_SPACE_BOT].heap_words = + dualmodeInfo.modeinfo[TWO_SPACE_TOP].heap_words = SM_word_heap_size; + + dualmodeInfo.modeinfo[TWO_SPACE_BOT].base = + HEAP_FRAME_BASE(heap_space, semispaceSize); + dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim = + HEAP_FRAME_LIMIT(heap_space, semispaceSize); + dualmodeInfo.modeinfo[TWO_SPACE_TOP].base = + HEAP_FRAME_BASE(heap_space + semispaceSize, semispaceSize); + dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim = + HEAP_FRAME_LIMIT(heap_space + semispaceSize, semispaceSize); + + dualmodeInfo.bit_words = (SM_word_heap_size + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + dualmodeInfo.bits = (BitWord *)(heap_space + SM_word_heap_size) - dualmodeInfo.bit_words; + + dualmodeInfo.modeinfo[COMPACTING].heap_words = + SM_word_heap_size - dualmodeInfo.bit_words; + dualmodeInfo.modeinfo[COMPACTING].base = + HEAP_FRAME_BASE(heap_space, SM_word_heap_size - dualmodeInfo.bit_words); + dualmodeInfo.modeinfo[COMPACTING].lim = + HEAP_FRAME_LIMIT(heap_space, SM_word_heap_size - dualmodeInfo.bit_words); + + stat_init("DUALMODE", "Collection", " Mode "); + } + + sm->hp = hp_start = dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1; + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + SM_alloc_min = 0; /* No min; alloc size specified */ + + if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) { + fprintf(stderr, "Not enough heap for requested alloc size\n"); + return -1; + } + } else { + sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim; + } + + sm->CAFlist = NULL; + +#ifndef PAR + initExtensions( sm ); +#endif /* !PAR */ + + if (SM_trace) { + fprintf(stderr, "DUALMODE Heap: TS base, TS lim, TS base, TS lim, CM base, CM lim, CM bits, bit words\n 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx, 0x%lx\n", + (W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].base, + (W_) dualmodeInfo.modeinfo[TWO_SPACE_BOT].lim, + (W_) dualmodeInfo.modeinfo[TWO_SPACE_TOP].base, + (W_) dualmodeInfo.modeinfo[TWO_SPACE_TOP].lim, + (W_) dualmodeInfo.modeinfo[COMPACTING].base, + (W_) dualmodeInfo.modeinfo[COMPACTING].lim, + (W_) dualmodeInfo.bits, dualmodeInfo.bit_words); + fprintf(stderr, "DUALMODE Initial: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) dualmodeInfo.mode, + (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base, + (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + } + + return 0; +} + +I_ +collectHeap(reqsize, sm, do_full_collection) + W_ reqsize; + smInfo *sm; + rtsBool do_full_collection; +{ + I_ start_mode; + + I_ free_space, /* No of words of free space following GC */ + alloc, /* Number of words allocated since last GC */ + resident, /* Number of words remaining after GC */ + bstk_roots; /* Number of update frames on B stack */ + StgFloat residency; /* % Words remaining after GC */ + + fflush(stdout); /* Flush stdout at start of GC */ + SAVE_REGS(&ScavRegDump); /* Save registers */ + + if (SM_trace) + fprintf(stderr, "DUALMODE Start: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n", + dualmodeInfo.mode, + (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base, + (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_))); + + alloc = sm->hp - hp_start; + stat_startGC(alloc); + + start_mode = dualmodeInfo.mode; + if (start_mode == COMPACTING) { + + /* PERFORM COMPACTING COLLECTION */ + + /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */ + RESTORE_REGS(&ScavRegDump); + + markHeapRoots(sm, sm->CAFlist, 0, + dualmodeInfo.modeinfo[COMPACTING].base, + dualmodeInfo.modeinfo[COMPACTING].lim, + dualmodeInfo.bits); + + SAVE_REGS(&ScavRegDump); + /* end of bracket */ + +#ifndef PAR + sweepUpDeadMallocPtrs(sm->MallocPtrList, + dualmodeInfo.modeinfo[COMPACTING].base, + dualmodeInfo.bits); +#endif + LinkCAFs(sm->CAFlist); + + LinkRoots( sm->roots, sm->rootno ); +#ifdef CONCURRENT + LinkSparks(); +#endif +#ifdef PAR + LinkLiveGAs(dualmodeInfo.modeinfo[COMPACTING].base, dualmodeInfo.bits); +#else + DEBUG_STRING("Linking Stable Pointer Table:"); + LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable); + LinkAStack( MAIN_SpA, stackInfo.botA ); + LinkBStack( MAIN_SuB, stackInfo.botB ); +#endif + + /* Do Inplace Compaction */ + /* Returns start of next closure, -1 gives last allocated word */ + + sm->hp = Inplace_Compaction(dualmodeInfo.modeinfo[COMPACTING].base, + dualmodeInfo.modeinfo[COMPACTING].lim, + 0, 0, + dualmodeInfo.bits, + dualmodeInfo.bit_words +#ifndef PAR + ,&(sm->MallocPtrList) +#endif + ) - 1; + + } else { + + /* COPYING COLLECTION */ + + dualmodeInfo.mode = NEXT_SEMI_SPACE(start_mode); + ToHp = dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1; + Scav = dualmodeInfo.modeinfo[dualmodeInfo.mode].base; + /* Point to (info field of) first closure */ + + SetCAFInfoTables( sm->CAFlist ); + EvacuateCAFs( sm->CAFlist ); +#ifdef PAR + EvacuateLocalGAs(rtsTrue); +#else + evacSPTable( sm ); +#endif /* PAR */ + EvacuateRoots( sm->roots, sm->rootno ); +#ifdef CONCURRENT + EvacuateSparks(); +#endif +#ifndef PAR + EvacuateAStack( MAIN_SpA, stackInfo.botA ); + EvacuateBStack( MAIN_SuB, stackInfo.botB, &bstk_roots ); +#endif /* !PAR */ + + Scavenge(); + +#ifdef PAR + RebuildGAtables(rtsTrue); +#else + reportDeadMallocPtrs(sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); +#endif /* PAR */ + + sm->hp = hp_start = ToHp; /* Last allocated word */ + } + + /* Use residency to determine if a change in mode is required */ + + resident = sm->hp - (dualmodeInfo.modeinfo[dualmodeInfo.mode].base - 1); + residency = resident / (StgFloat) SM_word_heap_size; + DO_MAX_RESIDENCY(resident); /* stats only */ + + if ((start_mode == TWO_SPACE_TOP) && + (residency > dualmodeInfo.resid_to_compact)) { + DEBUG_STRING("Changed Mode: Two Space => Compacting"); + dualmodeInfo.mode = COMPACTING; + + /* Zero bit vector for marking phase at next collection */ + { BitWord *ptr = dualmodeInfo.bits, + *end = dualmodeInfo.bits + dualmodeInfo.bit_words; + while (ptr < end) { *(ptr++) = 0; }; + } + + } else if ((start_mode == COMPACTING) && + (residency < dualmodeInfo.resid_from_compact)) { + DEBUG_STRING("Changed Mode: Compacting => Two Space"); + dualmodeInfo.mode = TWO_SPACE_BOT; + } + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + if (sm->hplim > dualmodeInfo.modeinfo[dualmodeInfo.mode].lim) { + free_space = 0; + } else { + free_space = SM_alloc_size; + } + } else { + sm->hplim = dualmodeInfo.modeinfo[dualmodeInfo.mode].lim; + free_space = sm->hplim - sm->hp; + } + + hp_start = sm->hp; + + stat_endGC(alloc, dualmodeInfo.modeinfo[start_mode].heap_words, + resident, dualmodeInfo.modeinfo[start_mode].name); + + if (SM_trace) + fprintf(stderr, "DUALMODE Done: mode %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + dualmodeInfo.mode, + (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].base, + (W_) dualmodeInfo.modeinfo[dualmodeInfo.mode].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) ((sm->hplim - sm->hp) * sizeof(W_))); + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating. */ + TrashMem(sm->hp+1, sm->hplim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + if ((SM_alloc_min > free_space) || (reqsize > free_space)) + return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */ + else + return GC_SUCCESS; /* Heap OK */ +} + +#endif /* GCdu */ + +\end{code} + diff --git a/ghc/runtime/storage/SMevac.lc b/ghc/runtime/storage/SMevac.lc new file mode 100644 index 0000000000..0eab98b906 --- /dev/null +++ b/ghc/runtime/storage/SMevac.lc @@ -0,0 +1,1203 @@ +%**************************************************************************** + +The files SMevac.lc and SMscav.lhc contain the basic routines required +for two-space copying garbage collection. + +Two files are required as the evac routines are conventional call/return +routines while the scavenge routines are continuation routines. + +This file SMevac.lc contains the evacuation routines ... + +See SMscav.lhc for calling convention documentation. + +%**************************************************************************** + +\begin{code} +#define SCAV_REG_MAP +#include "SMinternal.h" + +#if defined(_INFO_COPYING) + +/* Moves ToHp to point at the info pointer of the new to-space closure */ +#define START_ALLOC(size) ToHp += 1 + +/* Moves ToHp to point to the last word allocated in to-space */ +#define FINISH_ALLOC(size) ToHp += (FIXED_HS-1) + (size) + + +/* Copy the ith word (starting at 0) */ +#define COPY_WORD(position) ToHp[position] = evac[position] + +/* Copy the ith ptr (starting at 0), adjusting by offset */ +#define ADJUST_WORD(pos,off) ((PP_)ToHp)[pos] = ((PP_)evac)[pos] + (off) + +/* Copy the nth free var word in a SPEC closure (starting at 1) */ +#define SPEC_COPY_FREE_VAR(n) COPY_WORD((SPEC_HS-1) + (n)) + +#if FIXED_HS == 1 +#define COPY_FIXED_HDR COPY_WORD(0) +#else +#if FIXED_HS == 2 +#define COPY_FIXED_HDR COPY_WORD(0);COPY_WORD(1) +#else +#if FIXED_HS == 3 +#define COPY_FIXED_HDR COPY_WORD(0);COPY_WORD(1);COPY_WORD(2) +#else +/* I don't think this will be needed (ToDo: #error?) */ +#endif /* FIXED_HS != 1, 2, or 3 */ +#endif +#endif + + +/*** DEBUGGING MACROS ***/ + +#if defined(_GC_DEBUG) + +#define DEBUG_EVAC(sizevar) \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \ + evac, ToHp, INFO_PTR(evac), sizevar) + +#define DEBUG_EVAC_DYN \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Dyn info 0x%lx, size %lu\n", \ + evac, ToHp, INFO_PTR(evac), DYN_CLOSURE_SIZE(evac)) + +#define DEBUG_EVAC_TUPLE \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Tuple info 0x%lx, size %lu\n", \ + evac, ToHp, INFO_PTR(evac), TUPLE_CLOSURE_SIZE(evac)) + +#define DEBUG_EVAC_MUTUPLE \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, MuTuple info 0x%lx, size %lu\n", \ + evac, ToHp, INFO_PTR(evac), MUTUPLE_CLOSURE_SIZE(evac)) + +#define DEBUG_EVAC_DATA \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, Data info 0x%lx, size %lu\n", \ + evac, ToHp, INFO_PTR(evac), DATA_CLOSURE_SIZE(evac)) + +#define DEBUG_EVAC_BH(sizevar) \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BH info 0x%lx, size %ld\n", \ + evac, ToHp, INFO_PTR(evac), sizevar) + +#define DEBUG_EVAC_FORWARD \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Forward 0x%lx -> 0x%lx, info 0x%lx\n", \ + evac, FORWARD_ADDRESS(evac), INFO_PTR(evac)) + +#define DEBUG_EVAC_IND1 \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \ + evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac)) + +#define DEBUG_EVAC_IND2 \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Indirection Done -> 0x%lx\n", evac) + +#define DEBUG_EVAC_PERM_IND \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Permanent Indirection 0x%lx -> Evac(0x%lx), info 0x%lx\n", \ + evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac)) + +#define DEBUG_EVAC_CAF_EVAC1 \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Caf 0x%lx -> Evac(0x%lx), info 0x%lx\n", \ + evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac)) + +#define DEBUG_EVAC_CAF_EVAC2 \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Caf Done -> 0x%lx\n", evac) + +#define DEBUG_EVAC_CAF_RET \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Caf 0x%lx -> 0x%lx, info 0x%lx\n", \ + evac, IND_CLOSURE_PTR(evac), INFO_PTR(evac)) + +#define DEBUG_EVAC_STAT \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Static 0x%lx -> 0x%lx, info 0x%lx\n", \ + evac, evac, INFO_PTR(evac)) + +#define DEBUG_EVAC_CONST \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: Const 0x%lx -> 0x%lx, info 0x%lx\n", \ + evac, CONST_STATIC_CLOSURE(INFO_PTR(evac)), INFO_PTR(evac)) + +#define DEBUG_EVAC_CHARLIKE \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: CharLike (%lx) 0x%lx -> 0x%lx, info 0x%lx\n", \ + evac, CHARLIKE_VALUE(evac), CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac)), INFO_PTR(evac)) + +#define DEBUG_EVAC_INTLIKE_TO_STATIC \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: IntLike to Static (%ld) 0x%lx -> 0x%lx, info 0x%lx\n", \ + INTLIKE_VALUE(evac), evac, INTLIKE_CLOSURE(INTLIKE_VALUE(evac)), INFO_PTR(evac)) + +#define DEBUG_EVAC_TO_OLD \ + if (SM_trace & 2) \ + fprintf(stderr, "Old ") + +#define DEBUG_EVAC_TO_NEW \ + if (SM_trace & 2) \ + fprintf(stderr, "New ") + +#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) \ + if (SM_trace & 2) \ + fprintf(stderr, " OldRoot: 0x%lx -> Old 0x%lx (-> New 0x%lx)\n", \ + evac, oldind, newevac) + +#define DEBUG_EVAC_OLDROOT_FORWARD \ + if (SM_trace & 2) { \ + fprintf(stderr, "Evac: OldRoot Forward 0x%lx -> Old 0x%lx ", evac, FORWARD_ADDRESS(evac)); \ + if (! InOldGen(Scav)) fprintf(stderr, "-> New 0x%lx ", IND_CLOSURE_PTR(FORWARD_ADDRESS(evac))); \ + fprintf(stderr, "info 0x%lx\n", INFO_PTR(evac)); \ + } + +#ifdef CONCURRENT +#define DEBUG_EVAC_BQ \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BQ info 0x%lx, size %lu\n", \ + evac, ToHp, INFO_PTR(evac), BQ_CLOSURE_SIZE(evac)) + +#define DEBUG_EVAC_TSO(size) \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac TSO: 0x%lx -> 0x%lx, size %ld\n", \ + evac, ToHp, size) + +#define DEBUG_EVAC_STKO(a,b) \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac StkO: 0x%lx -> 0x%lx, size %ld (A), %ld (B)\n", \ + evac, ToHp, a, b) + +# ifdef PAR +# define DEBUG_EVAC_BF \ + if (SM_trace & 2) \ + fprintf(stderr, "Evac: 0x%lx -> 0x%lx, BF info 0x%lx, size %lu\n", \ + evac, ToHp, INFO_PTR(evac), BF_CLOSURE_SIZE(dummy)) +# endif + +#endif + +#else + +#define DEBUG_EVAC(size) +#define DEBUG_EVAC_DYN +#define DEBUG_EVAC_TUPLE +#define DEBUG_EVAC_MUTUPLE +#define DEBUG_EVAC_DATA +#define DEBUG_EVAC_BH(size) +#define DEBUG_EVAC_FORWARD +#define DEBUG_EVAC_IND1 +#define DEBUG_EVAC_IND2 +#define DEBUG_EVAC_PERM_IND +#define DEBUG_EVAC_CAF_EVAC1 +#define DEBUG_EVAC_CAF_EVAC2 +#define DEBUG_EVAC_CAF_RET +#define DEBUG_EVAC_STAT +#define DEBUG_EVAC_CONST +#define DEBUG_EVAC_CHARLIKE +#define DEBUG_EVAC_INTLIKE_TO_STATIC +#define DEBUG_EVAC_TO_OLD +#define DEBUG_EVAC_TO_NEW +#define DEBUG_EVAC_OLDROOT_FORWARD +#define DEBUG_EVAC_OLD_TO_NEW(oldind, evac, new) + +#ifdef CONCURRENT +# define DEBUG_EVAC_BQ +# define DEBUG_EVAC_TSO(size) +# define DEBUG_EVAC_STKO(s,size) +# ifdef PAR +# define DEBUG_EVAC_BF +# endif +#endif + +#endif /* not _GC_DEBUG */ + + +#if defined(GCgn) + +/* Evacuation with Promotion -- Have to decide if we promote ! */ +/* This is done by fiddling the ToHp pointer before calling */ +/* the real _do_Evacute code, passing reqd forward ref info */ + +/* Is a heap ptr in the old generation ? */ +#define InOldGen(hpptr) (((P_)(hpptr)) <= OldGen) + +/* Should we promote to the old generation ? */ +#define ShouldPromote(evac) (((P_)(evac)) < AllocGen) + + +/*** Real Evac Code -- passed closure & forward ref info ***/ + +#define EVAC_FN(suffix) \ + P_ CAT2(_do_Evacuate_,suffix)(evac, forward_info) \ + P_ evac; P_ forward_info; + + +/*** Evac Decision Code -- calls real evac code ***/ + +extern P_ _Evacuate_Old_to_New(); + +#define GEN_EVAC_CODE(suffix) \ + P_ CAT2(_Evacuate_,suffix)(evac) \ + P_ evac; \ + { \ + P_ newevac, tmp; \ + if (ShouldPromote(evac)) { \ + DEBUG_EVAC_TO_OLD; \ + tmp = ToHp; ToHp = OldHp; \ + newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_Old_info); \ + OldHp = ToHp; ToHp = tmp; \ + } else { \ + DEBUG_EVAC_TO_NEW; \ + newevac = CAT2(_do_Evacuate_,suffix)(evac, (P_)Forward_Ref_New_info); \ + \ + /* Check if new gen closure is scavenged from the old gen */ \ + if (InOldGen(Scav)) { \ + newevac = (P_) _Evacuate_Old_to_New(newevac, evac); \ + } \ + } \ + return newevac; \ + } + + +/*** FORWARD REF STUFF ***/ + +/*** Setting Forward Ref: grab argument passed to evac code ***/ + +/* Note that writing in the forwarding address trashes part of the + closure. This is normally fine since, if we want the data, we'll + have made a copy of it. + + But, Malloc Pointer closures are special: we have to make sure that + we don't damage either the linked list (which will include both + copied and uncopied Malloc ptrs) or the data (which we must report + to the outside world). Malloc Ptr closures are carefully designed + to have a little extra space in them that can be safely + overwritten. [ADR] +*/ + +#define SET_FORWARD_REF(closure, forw) \ + SET_INFO_PTR(closure,forward); /* arg passed to evac function */ \ + FORWARD_ADDRESS(closure) = (W_)(forw) + + +P_ +_Evacuate_Old_Forward_Ref(evac) +P_ evac; +{ + /* Forward ref to old generation -- just return */ + DEBUG_EVAC_FORWARD; + + evac = (P_) FORWARD_ADDRESS(evac); + return(evac); +} + +P_ +_Evacuate_New_Forward_Ref(evac) +P_ evac; +{ + /* Forward ref to new generation -- check scavenged from the old gen */ + DEBUG_EVAC_FORWARD; + + if (InOldGen(Scav)) { + evac = (P_) _Evacuate_Old_to_New(FORWARD_ADDRESS(evac), evac); + } else { + evac = (P_) FORWARD_ADDRESS(evac); + } + return(evac); +} + +P_ +_Evacuate_OldRoot_Forward(evac) +P_ evac; +{ + /* Forward ref to old generation root -- return old root or new gen closure */ + DEBUG_EVAC_OLDROOT_FORWARD; + + /* grab old generation root */ + evac = (P_) FORWARD_ADDRESS(evac); + + /* if scavenging new generation return the new generation + closure rather than the old generation root */ + if (! InOldGen(Scav)) { + evac = (P_) IND_CLOSURE_PTR(evac); + } + + return(evac); +} + +EXTDATA_RO(Forward_Ref_New_info); +EXTDATA_RO(Forward_Ref_Old_info); +EXTDATA_RO(OldRoot_Forward_Ref_info); + +/*** Old Gen Reference to New Gen Closure ***/ + +P_ +_Evacuate_Old_to_New(newevac, evac) +P_ newevac, evac; +{ + /* New generation closure referenced from the old generation */ + /* allocate old generation indirection to newevac */ + /* reset forward reference in original allocation area to oldind */ + /* evacuating this should return the old root or the new gen */ + /* closure depending if referenced from the old generation */ + /* return oldind as evacuated location */ + /* reference from oldgen will be to this oldind closure */ + + P_ oldind = OldHp + 1; /* see START_ALLOC */ + OldHp = oldind + (FIXED_HS-1) + MIN_UPD_SIZE; /* see FINISH_ALLOC */ + + DEBUG_EVAC_OLD_TO_NEW(oldind, evac, newevac); + + INFO_PTR(evac) = (W_) OldRoot_Forward_Ref_info; + FORWARD_ADDRESS(evac) = (W_)oldind; + + INFO_PTR(oldind) = (W_) OldRoot_info; + IND_CLOSURE_PTR(oldind) = (W_) newevac; + IND_CLOSURE_LINK(oldind) = (W_) genInfo.OldInNew; + genInfo.OldInNew = oldind; + genInfo.OldInNewno++; + + return oldind; +} + +#define PROMOTE_MUTABLE(evac) \ + if (InOldGen(evac)) { \ + MUT_LINK(evac) = (W_) genInfo.PromMutables; \ + genInfo.PromMutables = (P_) evac; \ + } + +#else /* ! GCgn */ + +#if defined(GCap) + +#define PROMOTE_MUTABLE(evac) \ + MUT_LINK(evac) = (W_) appelInfo.PromMutables; \ + appelInfo.PromMutables = (P_) evac; + +#else + +#define PROMOTE_MUTABLE(evac) + +#endif /* GCap */ + +/*** Real Evac Code -- simply passed closure ***/ + +#define EVAC_FN(suffix) \ + P_ CAT2(_Evacuate_,suffix)(evac) \ + P_ evac; + +/*** FORWARD REF STUFF ***/ + +#define SET_FORWARD_REF(closure, forw) \ + SET_INFO_PTR(closure, Forward_Ref_info); \ + FORWARD_ADDRESS(closure) = (W_) (forw) + +P_ +_Evacuate_Forward_Ref(evac) +P_ evac; +{ + DEBUG_EVAC_FORWARD; + evac = (P_) FORWARD_ADDRESS(evac); + return(evac); +} + +EXTDATA_RO(Forward_Ref_info); + +#endif /* ! GCgn */ + + +/*** SPECIALISED CODE ***/ + +/* Note: code for evacuating selectors is given near that for Ind(irections) */ + +EVAC_FN(1) +{ + START_ALLOC(1); + + DEBUG_EVAC(1); + COPY_FIXED_HDR; + SPEC_COPY_FREE_VAR(1); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(1); + return(evac); +} + +EVAC_FN(2) +{ + START_ALLOC(2); + DEBUG_EVAC(2); + COPY_FIXED_HDR; + SPEC_COPY_FREE_VAR(1); + SPEC_COPY_FREE_VAR(2); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(2); + return(evac); +} + +EVAC_FN(3) +{ + START_ALLOC(3); + DEBUG_EVAC(3); + COPY_FIXED_HDR; + SPEC_COPY_FREE_VAR(1); + SPEC_COPY_FREE_VAR(2); + SPEC_COPY_FREE_VAR(3); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(3); + return(evac); +} + +EVAC_FN(4) +{ + START_ALLOC(4); + DEBUG_EVAC(4); + COPY_FIXED_HDR; + SPEC_COPY_FREE_VAR(1); + SPEC_COPY_FREE_VAR(2); + SPEC_COPY_FREE_VAR(3); + SPEC_COPY_FREE_VAR(4); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(4); + return(evac); +} + +EVAC_FN(5) +{ + START_ALLOC(5); + DEBUG_EVAC(5); + COPY_FIXED_HDR; + SPEC_COPY_FREE_VAR(1); + SPEC_COPY_FREE_VAR(2); + SPEC_COPY_FREE_VAR(3); + SPEC_COPY_FREE_VAR(4); + SPEC_COPY_FREE_VAR(5); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(5); + return(evac); +} + +#define BIG_SPEC_EVAC_FN(n) \ +EVAC_FN(n) \ +{ \ + int i; \ + START_ALLOC(n); \ + DEBUG_EVAC(n); \ + COPY_FIXED_HDR; \ + for (i = 1; i <= n; i++) { SPEC_COPY_FREE_VAR(i); } \ + SET_FORWARD_REF(evac,ToHp); \ + evac = ToHp; \ + FINISH_ALLOC(n); \ + return(evac); \ +} + +/* instantiate for 6--12 */ +BIG_SPEC_EVAC_FN(6) +BIG_SPEC_EVAC_FN(7) +BIG_SPEC_EVAC_FN(8) +BIG_SPEC_EVAC_FN(9) +BIG_SPEC_EVAC_FN(10) +BIG_SPEC_EVAC_FN(11) +BIG_SPEC_EVAC_FN(12) + +\end{code} + +A @SPEC_RBH@ must be at least size @MIN_UPD_SIZE@ (Who are we fooling? +This means 2), and the first word after the fixed header is a +@MUT_LINK@. The second word is a pointer to a blocking queue. +Remaining words are the same as the underlying @SPEC@ closure. Unlike +their @SPEC@ cousins, @SPEC_RBH@ closures require special handling for +generational collectors, because the blocking queue is a mutable +field. + +We don't expect to have a lot of these, so I haven't unrolled the +first five instantiations of the macro, but feel free to do so if it +turns you on. + +\begin{code} + +#ifdef PAR + +#define SPEC_RBH_EVAC_FN(n) \ +EVAC_FN(CAT2(RBH_,n)) \ +{ \ + int i; \ + START_ALLOC(n); \ + DEBUG_EVAC(n); \ + COPY_FIXED_HDR; \ + for (i = 0; i < n - 1; i++) { COPY_WORD(SPEC_RBH_HS + i); } \ + SET_FORWARD_REF(evac,ToHp); \ + evac = ToHp; \ + FINISH_ALLOC(n); \ + PROMOTE_MUTABLE(evac);\ + return(evac); \ +} + +/* instantiate for 2--12 */ +SPEC_RBH_EVAC_FN(2) +SPEC_RBH_EVAC_FN(3) +SPEC_RBH_EVAC_FN(4) +SPEC_RBH_EVAC_FN(5) +SPEC_RBH_EVAC_FN(6) +SPEC_RBH_EVAC_FN(7) +SPEC_RBH_EVAC_FN(8) +SPEC_RBH_EVAC_FN(9) +SPEC_RBH_EVAC_FN(10) +SPEC_RBH_EVAC_FN(11) +SPEC_RBH_EVAC_FN(12) + +#endif + +#ifndef PAR +EVAC_FN(MallocPtr) +{ + START_ALLOC(MallocPtr_SIZE); + DEBUG_EVAC(MallocPtr_SIZE); + +#if defined(_GC_DEBUG) + if (SM_trace & 16) { + printf("DEBUG: Evacuating MallocPtr(%x)=<%x,_,%x,%x>", evac, evac[0], evac[2], evac[3]); + printf(" Data = %x, Next = %x\n", + MallocPtr_CLOSURE_DATA(evac), MallocPtr_CLOSURE_LINK(evac) ); + } +#endif + + COPY_FIXED_HDR; + + SET_FORWARD_REF(evac,ToHp); + MallocPtr_CLOSURE_DATA(ToHp) = MallocPtr_CLOSURE_DATA(evac); + MallocPtr_CLOSURE_LINK(ToHp) = MallocPtr_CLOSURE_LINK(evac); + +#if defined(_GC_DEBUG) + if (SM_trace & 16) { + printf("DEBUG: Evacuated MallocPtr(%x)=<%x,_,%x,%x>", ToHp, ToHp[0], ToHp[2], ToHp[3]); + printf(" Data = %x, Next = %x\n", + MallocPtr_CLOSURE_DATA(ToHp), MallocPtr_CLOSURE_LINK(ToHp) ); + } +#endif + + evac = ToHp; + FINISH_ALLOC(MallocPtr_SIZE); + return(evac); +} +#endif /* !PAR */ + +/*** GENERIC CASE CODE ***/ + +EVAC_FN(S) +{ + I_ count = FIXED_HS - 1; + I_ size = GEN_CLOSURE_SIZE(evac); + + START_ALLOC(size); + DEBUG_EVAC(size); + COPY_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + COPY_WORD(count); + } + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(size); + return(evac); +} + +\end{code} + +Like a @SPEC_RBH@, a @GEN_RBH@ must be at least @MIN_UPD_SIZE@, and +the first word after the fixed header is a @MUT_LINK@. The second +word is a pointer to a blocking queue. Remaining words are the same +as the underlying @GEN@ closure. + +\begin{code} + +#ifdef PAR +EVAC_FN(RBH_S) +{ + I_ count = GEN_RBH_HS - 1; + I_ size = GEN_RBH_CLOSURE_SIZE(evac); + + START_ALLOC(size); + DEBUG_EVAC(size); + COPY_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + COPY_WORD(count); + } + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(size); + + PROMOTE_MUTABLE(evac); + + return(evac); +} +#endif + +/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/ + +EVAC_FN(Dyn) +{ + I_ count = FIXED_HS - 1; + I_ size = DYN_CLOSURE_SIZE(evac); /* Includes size and no-of-ptrs fields */ + + START_ALLOC(size); + DEBUG_EVAC_DYN; + COPY_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + COPY_WORD(count); + } + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(size); + return(evac); +} + +/*** TUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/ + +EVAC_FN(Tuple) +{ + I_ count = FIXED_HS - 1; + I_ size = TUPLE_CLOSURE_SIZE(evac); + + START_ALLOC(size); + DEBUG_EVAC_TUPLE; + COPY_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + COPY_WORD(count); + } + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(size); + return(evac); +} + +/*** MUTUPLE CLOSURE -- NO. OF PTRS STORED IN CLOSURE -- NO DATA ***/ +/* Only if special GC treatment required */ + +#ifdef GC_MUT_REQUIRED +EVAC_FN(MuTuple) +{ + I_ count = FIXED_HS - 1; + I_ size = MUTUPLE_CLOSURE_SIZE(evac); + + START_ALLOC(size); + DEBUG_EVAC_MUTUPLE; + + COPY_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + COPY_WORD(count); + } + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(size); + + /* Add to OldMutables list (if evacuated to old generation) */ + PROMOTE_MUTABLE(evac); + + return(evac); +} +#endif /* GCgn or GCap */ + + +/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/ + +EVAC_FN(Data) +{ + I_ count = FIXED_HS - 1; + I_ size = DATA_CLOSURE_SIZE(evac); + + START_ALLOC(size); + DEBUG_EVAC_DATA; + COPY_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + COPY_WORD(count); + } + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(size); + return(evac); +} + + +/*** STATIC CLOSURE CODE ***/ + +/* Evacuation: Just return static address (no copying required) + Evac already contains this address -- just return */ +/* Scavenging: Static closures should never be scavenged */ + +P_ +_Evacuate_Static(evac) +P_ evac; +{ + DEBUG_EVAC_STAT; + return(evac); +} + +void +_Scavenge_Static(STG_NO_ARGS) +{ + fprintf(stderr,"Called _Scavenge_Static: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav)); + abort(); +} + + +/*** BLACK HOLE CODE ***/ + +EVAC_FN(BH_U) +{ + START_ALLOC(MIN_UPD_SIZE); + DEBUG_EVAC_BH(MIN_UPD_SIZE); + COPY_FIXED_HDR; + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(MIN_UPD_SIZE); + return(evac); +} + +EVAC_FN(BH_N) +{ + START_ALLOC(MIN_NONUPD_SIZE); + DEBUG_EVAC_BH(MIN_NONUPD_SIZE); + COPY_FIXED_HDR; + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(MIN_NONUPD_SIZE); + return(evac); +} + +/*** INDIRECTION CODE ***/ + +/* Evacuation: Evacuate closure pointed to */ + +P_ +_Evacuate_Ind(evac) +P_ evac; +{ + DEBUG_EVAC_IND1; + evac = (P_) IND_CLOSURE_PTR(evac); + +#if defined(GCgn) || defined(GCap) + if (evac > OldGen) /* Only evacuate new gen with generational collector */ + evac = EVACUATE_CLOSURE(evac); +#else + evac = EVACUATE_CLOSURE(evac); +#endif + + DEBUG_EVAC_IND2; + return(evac); + + /* This will generate a stack of returns for a chain of indirections! + However chains can only be 2 long. + */ +} + +#ifdef USE_COST_CENTRES +#undef PI +EVAC_FN(PI) +{ + START_ALLOC(MIN_UPD_SIZE); + DEBUG_EVAC_PERM_IND; + COPY_FIXED_HDR; + COPY_WORD(IND_HS); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(MIN_UPD_SIZE); + return(evac); +} +#endif + +/*** SELECTORS CODE (much like an indirection) ***/ + +/* Evacuate a thunk which is selector; it has one free variable which + points to something which will evaluate to a constructor in a + single-constructor data type. + + If it is so evaluated at GC time, we want to simply select the n'th + field. + + This thunk is of course always a Spec thing, since it has only one + free var. + + The constructor is guaranteed to be a Spec thing, so we know where + the n'th field is. + + ToDo: what if the constructor is a Gen thing? +*/ +static P_ +_EvacuateSelector_n(evac, n) + P_ evac; + I_ n; +{ + P_ maybe_con = (P_) evac[_FHS]; + + /* must be a SPEC 2 1 closure */ + ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */ + +#if defined(_GC_DEBUG) + if (SM_trace & 2) + fprintf(stderr, "Evac Selector: 0x%lx, info 0x%lx, maybe_con 0x%lx, info 0x%lx, tag %ld\n", + evac, INFO_PTR(evac), maybe_con, + INFO_PTR(maybe_con), INFO_TAG(INFO_PTR(maybe_con))); +#endif + + if (INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */ + /* Evacuate as normal (it is size *2* because of MIN_UPD_SIZE) */ + return( _Evacuate_2(evac) ); + +#if defined(_GC_DEBUG) + if (SM_trace & 2) + fprintf(stderr, "Evac Selector:shorting: 0x%lx -> 0x%lx\n", + evac, maybe_con[_FHS + n]); +#endif + + /* Ha! Short it out */ + evac = (P_) (maybe_con[_FHS + n]); /* evac now has the result of the selection */ + +#if defined(GCgn) || defined(GCap) + if (evac > OldGen) /* Only evacuate new gen with generational collector */ + evac = EVACUATE_CLOSURE(evac); +#else + evac = EVACUATE_CLOSURE(evac); +#endif + + return(evac); +} + +#define DEF_SEL_EVAC(n) \ +P_ CAT2(_EvacuateSelector_,n) (evac) P_ evac; \ +{ return(_EvacuateSelector_n(evac,n)); } + +/* all the entry points */ +DEF_SEL_EVAC(0) +DEF_SEL_EVAC(1) +DEF_SEL_EVAC(2) +DEF_SEL_EVAC(3) +DEF_SEL_EVAC(4) +DEF_SEL_EVAC(5) +DEF_SEL_EVAC(6) +DEF_SEL_EVAC(7) +DEF_SEL_EVAC(8) +DEF_SEL_EVAC(9) +DEF_SEL_EVAC(10) +DEF_SEL_EVAC(11) +DEF_SEL_EVAC(12) + +#ifdef CONCURRENT +EVAC_FN(BQ) +{ + START_ALLOC(MIN_UPD_SIZE); + DEBUG_EVAC_BQ; + + COPY_FIXED_HDR; + COPY_WORD(BQ_HS); + + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(MIN_UPD_SIZE); + + /* Add to OldMutables list (if evacuated to old generation) */ + PROMOTE_MUTABLE(evac); + + return(evac); +} + +EVAC_FN(TSO) +{ + I_ count; + + START_ALLOC(TSO_VHS + TSO_CTS_SIZE); + DEBUG_EVAC_TSO(TSO_VHS + TSO_CTS_SIZE); + + COPY_FIXED_HDR; + for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) { + COPY_WORD(count); + } + + *TSO_INTERNAL_PTR(ToHp) = *TSO_INTERNAL_PTR(evac); + + SET_FORWARD_REF(evac, ToHp); + evac = ToHp; + FINISH_ALLOC(TSO_VHS + TSO_CTS_SIZE); + + /* Add to OldMutables list (if evacuated to old generation) */ + PROMOTE_MUTABLE(evac); + + return evac; +} + +EVAC_FN(StkO) +{ + I_ count; + I_ size = STKO_CLOSURE_SIZE(evac); + I_ spa_offset = STKO_SpA_OFFSET(evac); + I_ spb_offset = STKO_SpB_OFFSET(evac); + I_ sub_offset = STKO_SuB_OFFSET(evac); + I_ offset; + + START_ALLOC(size); + DEBUG_EVAC_STKO(STKO_CLOSURE_CTS_SIZE(evac) - spa_offset + 1, spb_offset); + + COPY_FIXED_HDR; +#ifdef DO_REDN_COUNTING + COPY_WORD(STKO_ADEP_LOCN); + COPY_WORD(STKO_BDEP_LOCN); +#endif + COPY_WORD(STKO_SIZE_LOCN); + COPY_WORD(STKO_RETURN_LOCN); + COPY_WORD(STKO_LINK_LOCN); + + /* Adjust the four stack pointers -- ORDER IS IMPORTANT!! */ + offset = ToHp - evac; + + STKO_SuB(ToHp) = STKO_SuB(evac) + offset; + STKO_SpB(ToHp) = STKO_SpB(evac) + offset; + STKO_SpA(ToHp) = STKO_SpA(evac) + offset; + STKO_SuA(ToHp) = STKO_SuA(evac) + offset; + + + /* Slide the A stack */ + for (count = spa_offset; count <= STKO_CLOSURE_CTS_SIZE(evac); count++) { + COPY_WORD((STKO_HS-1) + count); + } + + /* Slide the B stack, repairing internal pointers */ + for (count = spb_offset; count >= 1;) { + if (count > sub_offset) { + COPY_WORD((STKO_HS-1) + count); + count--; + } else { + P_ subptr; + /* Repair the internal pointers in the update frame */ + COPY_WORD((STKO_HS-1) + count + BREL(UF_RET)); + COPY_WORD((STKO_HS-1) + count + BREL(UF_UPDATEE)); + ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUA),offset); + ADJUST_WORD((STKO_HS-1) + count + BREL(UF_SUB),offset); + subptr = GRAB_SuB(STKO_CLOSURE_ADDR(ToHp,sub_offset)); + sub_offset = STKO_CLOSURE_OFFSET(ToHp,subptr); + count -= STD_UF_SIZE; + } + } + + SET_FORWARD_REF(evac, ToHp); + evac = ToHp; + FINISH_ALLOC(size); + + /* Add to OldMutables list (if evacuated to old generation) */ + PROMOTE_MUTABLE(evac); + + return evac; +} + +#ifdef PAR +EVAC_FN(FetchMe) +{ + START_ALLOC(2); + DEBUG_EVAC(2); + COPY_FIXED_HDR; + COPY_WORD(FETCHME_GA_LOCN); + ASSERT(GALAlookup(FETCHME_GA(evac)) != NULL); + + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(2); + + /* Add to OldMutables list (if evacuated to old generation) */ + PROMOTE_MUTABLE(evac); + + return(evac); +} + +EVAC_FN(BF) +{ + I_ count; + + START_ALLOC(BF_CLOSURE_SIZE(evac)); + DEBUG_EVAC_BF; + + COPY_FIXED_HDR; + for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) { + COPY_WORD(count); + } + COPY_WORD(BF_LINK_LOCN); + COPY_WORD(BF_NODE_LOCN); + COPY_WORD(BF_GTID_LOCN); + COPY_WORD(BF_SLOT_LOCN); + COPY_WORD(BF_WEIGHT_LOCN); + + SET_FORWARD_REF(evac, ToHp); + evac = ToHp; + FINISH_ALLOC(BF_CLOSURE_SIZE(evac)); + + /* Add to OldMutables list (if evacuated to old generation) */ + PROMOTE_MUTABLE(evac); + + return evac; +} +#endif /* PAR */ +#endif /* CONCURRENT */ + +/*** SPECIAL CAF CODE ***/ + +/* Evacuation: Return closure pointed to (already explicitly evacuated) */ +/* Scavenging: Should not be scavenged */ + +P_ +_Evacuate_Caf(evac) +P_ evac; +{ + DEBUG_EVAC_CAF_RET; + evac = (P_) IND_CLOSURE_PTR(evac); + return(evac); +} + +/* In addition we need an internal Caf indirection which evacuates, + updates and returns the indirection. Before GC is started the + @CAFlist@ must be traversed and the info tables set to this. +*/ + +P_ +_Evacuate_Caf_Evac_Upd(evac) + P_ evac; +{ + P_ closure = evac; + + DEBUG_EVAC_CAF_EVAC1; + INFO_PTR(evac) = (W_) Caf_info; /* Change to return CAF */ + + evac = (P_) IND_CLOSURE_PTR(evac); /* Grab reference and evacuate */ + +#if defined(GCgn) || defined(GCap) + if (evac > OldGen) /* Only evacuate new gen with generational collector */ + evac = EVACUATE_CLOSURE(evac); +#else + evac = EVACUATE_CLOSURE(evac); +#endif + + IND_CLOSURE_PTR(closure) = (W_) evac; /* Update reference */ + + DEBUG_EVAC_CAF_EVAC2; + return(evac); + + /* This will generate a stack of returns for a chain of indirections! + However chains can only be 2 long. + */ +} + + +/*** CONST CLOSURE CODE ***/ + +/* Evacuation: Just return address of the static closure stored in the info table */ +/* Scavenging: Const closures should never be scavenged */ + +P_ +_Evacuate_Const(evac) +P_ evac; +{ + DEBUG_EVAC_CONST; + evac = CONST_STATIC_CLOSURE(INFO_PTR(evac)); + return(evac); +} + +void +_Scavenge_Const(STG_NO_ARGS) +{ + fprintf(stderr,"Called _Scavenge_Const: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav)); + abort(); +} + + +/*** CHARLIKE CLOSURE CODE ***/ + +/* Evacuation: Just return address of the static closure stored fixed array */ +/* Scavenging: CharLike closures should never be scavenged */ + +P_ +_Evacuate_CharLike(evac) +P_ evac; +{ + DEBUG_EVAC_CHARLIKE; + evac = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(evac)); + return(evac); +} + +void +_Scavenge_CharLike(STG_NO_ARGS) +{ + fprintf(stderr,"Called _Scavenge_CharLike: Closure %lx Info %lx\nShould never occur!\n", (W_) Scav, INFO_PTR(Scav)); + abort(); +} +\end{code} + +--- INTLIKE CLOSURE CODE --- + +Evacuation: Return address of the static closure if available +Otherwise evacuate converting to aux closure. + +Scavenging: IntLike closures should never be scavenged. + +There are some tricks here: +\begin{enumerate} +\item +The main trick is that if the integer is in a certain range, we +replace it by a pointer to a statically allocated integer. +\end{enumerate} + +(Would it not be more efficient to update the copy directly since +we're about to set a forwarding reference in the original? ADR) + +\begin{code} +EVAC_FN(IntLike) +{ + I_ val = INTLIKE_VALUE(evac); + + if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) { /* in range of static closures */ + DEBUG_EVAC_INTLIKE_TO_STATIC; + evac = (P_) INTLIKE_CLOSURE(val); /* return appropriate static closure */ + } + else { + START_ALLOC(1); /* evacuate closure of size 1 */ + DEBUG_EVAC(1); + COPY_FIXED_HDR; + SPEC_COPY_FREE_VAR(1); + SET_FORWARD_REF(evac,ToHp); + evac = ToHp; + FINISH_ALLOC(1); + } + return(evac); +} + +#if defined (GCgn) +GEN_EVAC_CODE(1) +GEN_EVAC_CODE(2) +GEN_EVAC_CODE(3) +GEN_EVAC_CODE(4) +GEN_EVAC_CODE(5) +GEN_EVAC_CODE(6) +GEN_EVAC_CODE(7) +GEN_EVAC_CODE(8) +GEN_EVAC_CODE(9) +GEN_EVAC_CODE(10) +GEN_EVAC_CODE(11) +GEN_EVAC_CODE(12) +GEN_EVAC_CODE(S) +GEN_EVAC_CODE(Dyn) +GEN_EVAC_CODE(Tuple) +GEN_EVAC_CODE(Data) +GEN_EVAC_CODE(MuTuple) +GEN_EVAC_CODE(IntLike) /* ToDo: may create oldgen roots referencing static ints */ +GEN_EVAC_CODE(CAT2(BH_,MIN_UPD_SIZE)) +GEN_EVAC_CODE(CAT2(BH_,MIN_NONUPD_SIZE)) +#endif /* GCgn */ + +#else /* ! _INFO_COPYING */ +This really really should not ever ever come up! +#endif /* ! _INFO_COPYING */ +\end{code} diff --git a/ghc/runtime/storage/SMextn.lc b/ghc/runtime/storage/SMextn.lc new file mode 100644 index 0000000000..bd39ae4169 --- /dev/null +++ b/ghc/runtime/storage/SMextn.lc @@ -0,0 +1,367 @@ +\section[SM-extensions]{Storage Manager Extensions} + +ToDo ADR: Maybe this should be split between SMcopying.lc and +SMcompacting.lc? + + +This is a collection of C functions use in implementing the stable +pointer and malloc pointer extensions. + +The motivation for making this a separate file/section is twofold: + +1) It let's us focus on one thing. + +2) If we don't do this, there will be a huge amount of repetition + between the various GC schemes --- a maintenance nightmare. + +The second is the major motivation. + +There are three main parts to this file: + +1) Code which is common to all GC schemes. + +2) Code for use in a compacting collector used in the 1-space, dual + mode and for collecting old generations in generational collectors. + +3) Code for use in a copying collector used in the 2-space, dual mode + and for collecting young generations in generational collectors. + +When debugging, it is incredibly helpful to trash part of the heap +(say) once you're done with it. + +Remembering that @sm->hp@ points to the next word to be allocated, a +typical use is + +\begin{pseudocode} +#ifdef DEBUG + TrashMem(sm->hp+1, sm->hplim); +#endif +\end{pseudocode} + +\begin{code} + +#if defined(GC1s) + +#define SCAN_REG_DUMP +#include "SMinternal.h" +REGDUMP(ScanRegDump); + +#else /* GC2s, GCdu, GCap, GCgn */ + +#define SCAV_REG_MAP +#include "SMinternal.h" +REGDUMP(ScavRegDump); + +#endif +#include "SMextn.h" + +#ifdef DEBUG + +void +TrashMem(from, to) + P_ from, to; +{ +/* assertion overly strong - if free_mem == 0, sm->hp == sm->hplim */ +/* ASSERT( from <= to ); */ + if (SM_trace) + printf("Trashing from 0x%lx to 0x%lx inclusive\n", (W_) from, (W_) to); + while (from <= to) { + *from++ = DEALLOCATED_TRASH; + } +} + +#endif /* DEBUG */ +\end{code} + +\begin{code} + +#ifndef PAR /* To end of the file */ + +\end{code} + +\downsection +\section[SM-extensions-common-code]{Code common to all GC schemes} + +\begin{code} +EXTDATA(EmptySPTable_closure); + +void initExtensions( sm ) + smInfo *sm; +{ + sm->MallocPtrList = NULL; +#if defined(GCap) || defined(GCgn) + sm->OldMallocPtrList = NULL; +#endif + + sm->StablePointerTable = (P_) EmptySPTable_closure; +} + +extern void FreeMallocPtr PROTO(( StgMallocPtr mp )); +\end{code} + +\begin{code} +#if defined(DEBUG) +\end{code} + +When a Malloc Pointer is released, there should be absolutely no +references to it. To encourage and dangling references to show +themselves, we'll trash its contents when we're done with it. + +\begin{code} +#define TRASH_MallocPtr_CLOSURE( mptr ) Trash_MallocPtr_Closure(mptr) + +void +Trash_MallocPtr_Closure(mptr) + P_ mptr; +{ int i; + for( i = 0; i != MallocPtr_SIZE + _FHS; i++ ) { + mptr[ i ] = DEALLOCATED_TRASH; + } +} +\end{code} + +Also, every time we fiddle with the MallocPtr list, we should check it +still makes sense. This function returns @0@ if the list is sensible. + +(Would maintaining a separate Malloc Ptr count allow better testing?) + +\begin{code} +void +Validate_MallocPtrList( MallocPtrList ) + P_ MallocPtrList; +{ + P_ MPptr; + + for(MPptr = MallocPtrList; + MPptr != NULL; + MPptr = MallocPtr_CLOSURE_LINK(MPptr) ) { + CHECK_MallocPtr_CLOSURE(MPptr); + } +} +\end{code} + +\begin{code} +#else /* !DEBUG */ + +#define TRASH_MallocPtr_CLOSURE( mp ) /* nothing */ + +#endif /* !DEBUG */ +\end{code} + +\begin{code} +#ifdef DEBUG + +#define TRACE_MallocPtr(MPptr) Trace_MallocPtr( MPptr ) +#define TRACE_MPdies(MPptr) Trace_MPdies() +#define TRACE_MPlives(MPptr) Trace_MPlives() +#define TRACE_MPforwarded(MPptr, newAddress) Trace_MPforwarded( MPptr, newAddress ) + +void +Trace_MallocPtr( MPptr ) + P_ MPptr; +{ + if (SM_trace & 16) { + printf("DEBUG: MallocPtr(%lx)=<%lx,_,%lx,%lx,%lx>\n", (W_) MPptr, (W_) MPptr[0], (W_) MPptr[1], (W_) MPptr[2], (W_) MPptr[3]); + printf(" Data = %lx, Next = %lx\n", + (W_) MallocPtr_CLOSURE_DATA(MPptr), (W_) MallocPtr_CLOSURE_LINK(MPptr) ); + } +} + +void +Trace_MPdies() +{ + if (SM_trace & 16) { + printf(" dying\n"); + } +} + +void +Trace_MPlives() +{ + if (SM_trace & 16) { + printf(" lived to tell the tale \n"); + } +} + +void +Trace_MPforwarded( MPPtr, newAddress ) + P_ MPPtr, newAddress; +{ + if (SM_trace & 16) { + printf(" forwarded to %lx\n", (W_) newAddress); + } +} + +#else + +#define TRACE_MallocPtr(MPptr) /* nothing */ +#define TRACE_MPdies(MPptr) /* nothing */ +#define TRACE_MPlives(MPptr) /* nothing */ +#define TRACE_MPforwarded(MPptr, newAddress) /* nothing */ + +#endif /* DEBUG */ +\end{code} + + +\section[SM-extensions-compacting-code]{Compacting Collector Code} + + +\begin{code} +#if defined(_INFO_COMPACTING) + +/* Sweep up the dead MallocPtrs */ + +/* Note that this has to happen before the linking phase trashes + the stable pointer table so that the FreeMallocPtr function can + safely call freeStablePointer. +*/ + +void +sweepUpDeadMallocPtrs( MallocPtrList, base, bits ) + P_ MallocPtrList; + P_ base; + BitWord *bits; +{ + P_ MPptr, temp; + I_ MallocPtr_deaths = 0; + long _hp_word, bit_index, bit; + + /* At this point, the MallocPtrList is in an invalid state (since + some info ptrs will have been mangled) so we can't validate + it. ADR */ + + DEBUG_STRING("Reporting Dead Malloc Ptrs:"); + MPptr = MallocPtrList; + while ( MPptr != NULL ) { + + TRACE_MallocPtr(MPptr); + + _hp_word = MPptr - base; + bit_index = _hp_word / BITS_IN(BitWord); + bit = 1L << (_hp_word & (BITS_IN(BitWord) - 1)); + if ( !( bits[bit_index] & bit ) ) { /* dead */ + + TRACE_MPdies( MPptr ); + FreeMallocPtr( MallocPtr_CLOSURE_DATA(MPptr) ); + MallocPtr_deaths++; + + temp = MPptr; + MPptr = MallocPtr_CLOSURE_LINK(MPptr); + /* Now trash the closure to encourage bugs to show themselves */ + TRASH_MallocPtr_CLOSURE( temp ); + + } else { + + TRACE_MPlives(MPptr); + MPptr = MallocPtr_CLOSURE_LINK(MPptr); + } + } +} + +#endif /* _INFO_COMPACTING */ +\end{code} + +\section[SM-extensions-copying-code]{Copying Collector Code} + +\begin{code} +#if defined(_INFO_COPYING) + +/* ToDo: a possible optimisation would be to maintain a flag that + told us whether the SPTable had been updated (with new + pointers) and so needs to be GC'd. A simple way of doing this + might be to generalise the MUTUPLE closures to MUGEN closures. +*/ +void evacSPTable( sm ) +smInfo *sm; +{ + DEBUG_STRING("Evacuate Stable Pointer Table:"); + { + P_ evac = sm->StablePointerTable; + sm->StablePointerTable = EVACUATE_CLOSURE(evac); + } +} + + + +/* First attempt at Malloc Ptr hackery... Later versions might + do something useful with the two counters. [ADR] */ + +#if defined(DEBUG) +#if defined(GCgn) + +EXTDATA_RO(Forward_Ref_New_info); +EXTDATA_RO(Forward_Ref_Old_info); +EXTDATA_RO(OldRoot_Forward_Ref_info); + +#else + +EXTDATA_RO(Forward_Ref_info); + +#endif +#endif + +/* + Call FreeMallocPtr on any dead MPs in oldMPList, add the remainder + to new sticking the result into newMPList. +*/ +void +reportDeadMallocPtrs(oldMPList, new, newMPList) + P_ oldMPList; + P_ new; + P_ *newMPList; +{ + P_ MPptr, temp; + I_ MP_no = 0, MP_deaths = 0; + + /* At this point, the MallocPtrList is in an invalid state (since + some info ptrs will have been mangled) so we can't validate + it. ADR */ + + DEBUG_STRING("Updating MallocPtr List and reporting casualties:"); + MPptr = oldMPList; + while ( MPptr != NULL ) { + TRACE_MallocPtr(MPptr); + + if ((P_) INFO_PTR(MPptr) == MallocPtr_info ) { + /* can't have been forwarded - must be dead */ + + TRACE_MPdies(MPptr); + FreeMallocPtr( MallocPtr_CLOSURE_DATA(MPptr) ); + MP_deaths++; + + temp = MPptr; + MPptr = MallocPtr_CLOSURE_LINK(MPptr); + + /* Now trash the closure to encourage bugs to show themselves */ + TRASH_MallocPtr_CLOSURE( temp ); + } else { /* Must have been forwarded - so it must be live */ + + P_ newAddress = (P_) FORWARD_ADDRESS(MPptr); + +#if defined(GCgn) + ASSERT( ( (P_) INFO_PTR(MPptr) == Forward_Ref_New_info ) || + ( (P_) INFO_PTR(MPptr) == Forward_Ref_Old_info ) || + ( (P_) INFO_PTR(MPptr) == OldRoot_Forward_Ref_info ) ); +#else + ASSERT( (P_) INFO_PTR(MPptr) == Forward_Ref_info ); +#endif + + TRACE_MPforwarded( MPptr, newAddress ); + MallocPtr_CLOSURE_LINK(newAddress) = new; + new = newAddress; + MP_no++; + MPptr = MallocPtr_CLOSURE_LINK(MPptr); + } + } + + VALIDATE_MallocPtrList( new ); + *newMPList = new; +} +#endif /* _INFO_COPYING */ +\end{code} + +\upsection + +\begin{code} +#endif /* !PAR */ +\end{code} diff --git a/ghc/runtime/storage/SMextn.lh b/ghc/runtime/storage/SMextn.lh new file mode 100644 index 0000000000..ed2e3a86e6 --- /dev/null +++ b/ghc/runtime/storage/SMextn.lh @@ -0,0 +1,40 @@ +\section[SMextensions-header]{Header file for SMextensions} + +\begin{code} +#ifndef PAR + +extern void initExtensions PROTO((smInfo *sm)); + +#if defined(_INFO_COPYING) + +extern void evacSPTable PROTO((smInfo *sm)); +extern void reportDeadMallocPtrs PROTO((StgPtr oldMPList, StgPtr new, StgPtr *newMPLust)); + +#endif /* _INFO_COPYING */ + +#if defined(_INFO_COMPACTING) + +extern void sweepUpDeadMallocPtrs PROTO(( + P_ MallocPtrList, + P_ base, + BitWord *bits + )); + +#endif /* _INFO_COMPACTING */ + +extern void TrashMem PROTO(( P_ from, P_ to )); + +#if defined(DEBUG) + +extern void Trash_MallocPtr_Closure PROTO((P_ mptr)); +extern void Validate_MallocPtrList PROTO(( P_ MallocPtrList )); + +extern void Trace_MPdies PROTO((void)); +extern void Trace_MPlives PROTO((void)); +extern void Trace_MPforwarded PROTO(( P_ MPPtr, P_ newAddress )); + + +#endif /* DEBUG */ + +#endif /* !PAR */ +\end{code} diff --git a/ghc/runtime/storage/SMgen.lc b/ghc/runtime/storage/SMgen.lc new file mode 100644 index 0000000000..302ee640f4 --- /dev/null +++ b/ghc/runtime/storage/SMgen.lc @@ -0,0 +1,832 @@ +*************************************************************************** + + GENERATIONAL GARBAGE COLLECTION + +Global heap requirements as for 1s and 2s collectors. + ++ All closures in the old generation that are updated must be + updated with indirections and placed on the linked list of + updated old generation closures. + + +Promotion collection: +--------------------- + +Collects allocation area into 2nd semi-space and promotes new semi-space +by collecting into old generation. + +evac < AllocGen ==> Collect to old generation (see _EvacuateP) + +Roots: Roots, Astk, Bstk, OldRoots, OldInNew, CAFlist, NewCAFlist + +OldRoots: Newly promoted closures may reference new semi-space. + + Discard OldInNew roots (promoted). + This keeps recent new gen roots in new gen. + Remember OldRoots in alloc (not promoted). + + When evacuating to new check if Scav in OldGen, if so + allocate oldgen root ind and add to OldInNew. + N.B. This includes evacuating a forward reference. + Set special forward ref to this OldGen root closure. + if oldgen evacs return oldgen root else return new gen. + +CAFlist: Remember NewCAFlist in OldCAFlist (promoted). + Remember CAFlist in NewCAFlist (not promoted). + +*************************************************************************** + +\begin{code} +#if defined(GCgn) + +#define SCAV_REG_MAP +#include "SMinternal.h" + +REGDUMP(ScavRegDump); + +genData genInfo = {0, 0, 0, 0, + 0, 0, /* Alloc */ + 0, {{0, 0}, {0, 0}}, /* New Gen */ + 0, 0, 0, 0, 0, 0, /* Old Gen */ + 0, 0, 0, 0, 0, 0, 0, /* OldRoots & CAfs */ + 0, {{0, 0}, {0, 0}} /* 2s */ + }; + +P_ heap_space = 0; /* Address of first word of slab + of memory allocated for heap */ + +P_ hp_start; /* Value of Hp when reduction was resumed */ + /* Always allocbase - 1 */ + +I_ +initHeap( sm ) + smInfo *sm; +{ + I_ heap_error = 0; + I_ bit_words; + + /* should cause link error */ + ADRpanic("Completely untested on SP and MP stuff... also doesn't benefit from commoning up in SMcopying and SMcompacting"); + + if (heap_space == 0) { /* allocates if it doesn't already exist */ + + /* Allocate the roots space */ + sm->roots = (P_ *) xmalloc( SM_MAXROOTS * sizeof(W_) ); + + /* Allocate the heap */ + heap_space = (P_) xmalloc((SM_word_heap_size + EXTRA_HEAP_WORDS) * sizeof(W_)); + + if (SM_force_gc == USE_2s) { + stat_init("TWOSPACE(GEN)", + " No of Roots Caf Caf Astk Bstk", + "Astk Bstk Reg No bytes bytes bytes"); + } else { + stat_init("GEN", + "Promote Old No of Roots Caf Mut- Old Old OldGen Collec Resid", + " bytes roots Astk Bstk Reg No able Alc New bytes tion %heap"); + } + } + + if (SM_force_gc == USE_2s) { + genInfo.semi_space = SM_word_heap_size / 2; + genInfo.space[0].base = HEAP_FRAME_BASE(heap_space, genInfo.semi_space); + genInfo.space[1].base = HEAP_FRAME_BASE(heap_space + genInfo.semi_space, genInfo.semi_space); + genInfo.space[0].lim = HEAP_FRAME_LIMIT(heap_space, genInfo.semi_space); + genInfo.space[1].lim = HEAP_FRAME_LIMIT(heap_space + genInfo.semi_space, genInfo.semi_space); + genInfo.semi_space = 0; + genInfo.oldlim = heap_space - 1; /* Never in old generation */ + + sm->hp = hp_start = genInfo.space[genInfo.semi_space].base - 1; + + if (SM_alloc_size) { + sm->hplim = sm->hp + SM_alloc_size; + SM_alloc_min = 0; /* No min; alloc size specified */ + + if (sm->hplim > genInfo.space[genInfo.semi_space].lim) { + fprintf(stderr, "Not enough heap for requested alloc size\n"); + return -1; + } + } else { + sm->hplim = genInfo.space[genInfo.semi_space].lim; + } + + sm->OldLim = genInfo.oldlim; + sm->CAFlist = NULL; + +#ifndef PAR + initExtensions( sm ); +#endif + + if (SM_trace) { + fprintf(stderr, "GEN(2s) Heap: 0x%lx .. 0x%lx\n", + (W_) heap_space, (W_) (heap_space - 1 + SM_word_heap_size)); + fprintf(stderr, "Initial: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %ld\n", + genInfo.semi_space, + (W_) genInfo.space[genInfo.semi_space].base, + (W_) genInfo.space[genInfo.semi_space].lim, + (W_) sm->hp, (W_) sm->hplim, (I_) (sm->hplim - sm->hp)); + } + return 0; + } + + if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE; + + genInfo.alloc_words = SM_alloc_size; + genInfo.new_words = SM_alloc_size; + + genInfo.allocbase = heap_space + SM_word_heap_size - genInfo.alloc_words; + genInfo.alloclim = heap_space + SM_word_heap_size - 1; + + genInfo.newgen[0].newbase = genInfo.allocbase - genInfo.new_words; + genInfo.newgen[0].newlim = genInfo.newgen[0].newbase - 1; + + genInfo.newgen[1].newbase = genInfo.allocbase - 2 * genInfo.new_words; + genInfo.newgen[1].newlim = genInfo.newgen[1].newbase - 1; + + genInfo.oldbase = heap_space; + + if (SM_major_gen_size) { + genInfo.old_words = SM_major_gen_size; + genInfo.oldend = heap_space + genInfo.old_words - 1; + genInfo.oldthresh = genInfo.oldend - genInfo.new_words; + /* ToDo: extra old ind words not accounted for ! */ + + bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) { + /* bit vector in allocation area */ + genInfo.bit_vect = (BitWord *) genInfo.allocbase; + if (genInfo.oldend >= genInfo.newgen[1].newbase) heap_error = 1; + } else { + /* bit area in free area */ + genInfo.bit_vect = (BitWord *) genInfo.oldend + 1; + if (genInfo.bit_vect + bit_words >= (BitWord *) genInfo.newgen[1].newbase) heap_error = 1; + } + } else { + genInfo.old_words = SM_word_heap_size - genInfo.alloc_words - 2 * genInfo.new_words; + genInfo.oldend = heap_space + genInfo.old_words - 1; + genInfo.oldthresh = genInfo.oldend - genInfo.new_words; + /* ToDo: extra old ind words not accounted for ! */ + + bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + if (genInfo.alloc_words > bit_words * (sizeof(BitWord)/sizeof(W_))) { + /* bit vector in allocation area */ + genInfo.bit_vect = (BitWord *) genInfo.allocbase; + } else { + /* bit vector in reserved space in old generation */ + bit_words = (genInfo.old_words + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + + genInfo.bit_vect = (BitWord *) heap_space; + genInfo.oldbase += bit_words; + genInfo.old_words -= bit_words; + } + if (genInfo.oldbase > genInfo.oldthresh) heap_error = 1; + } + + if (heap_error) { + fprintf(stderr, "initHeap: Requested heap size: %ld\n", SM_word_heap_size); + fprintf(stderr, " Alloc area %ld Delay area %ld Old area %ld Bit area %ld\n", + genInfo.alloc_words, genInfo.new_words * 2, genInfo.old_words, + genInfo.bit_vect == (BitWord *) genInfo.allocbase ? 0 : bit_words); + fprintf(stderr, " Heap not large enough for generational gc with these specs\n"); + fprintf(stderr, " +RTS -H<size> option will increase heap size and/or\n"); + fprintf(stderr, " -A<size> option will decrease allocation area\n"); + return -1; + } + + + genInfo.oldlim = genInfo.oldbase - 1; + genInfo.oldwas = genInfo.oldbase - 1; + + genInfo.curnew = 0; + genInfo.OldInNew = 0; + genInfo.OldInNewno = 0; + genInfo.NewCAFlist = NULL; + genInfo.NewCAFno = 0; + genInfo.OldCAFlist = NULL; + genInfo.OldCAFno = 0; + + genInfo.PromMutables = 0; + + sm->hp = hp_start = genInfo.allocbase - 1; + sm->hplim = genInfo.alloclim; + + sm->OldLim = genInfo.oldlim; + sm->CAFlist = NULL; + +#ifndef PAR + initExtensions( sm ); +#endif + + if (SM_trace) { + fprintf(stderr, "GEN Heap: 0x%lx .. 0x%lx\n", + (W_) heap_space, (W_) (heap_space + SM_word_heap_size - 1)); + fprintf(stderr, " alloc %ld, new %ld, old %ld, bit %ld\n", + genInfo.alloc_words, genInfo.new_words, genInfo.old_words, bit_words); + fprintf(stderr, " allocbase 0x%lx, alloclim 0x%lx\n", + (W_) genInfo.allocbase, (W_) genInfo.alloclim); + fprintf(stderr, " newbases 0x%lx 0x%lx\n", + (W_) genInfo.newgen[0].newbase, (W_) genInfo.newgen[1].newbase); + fprintf(stderr, " oldbase 0x%lx oldthresh 0x%lx bits 0x%lx\n", + (W_) genInfo.oldbase, (W_) genInfo.oldthresh, (W_) genInfo.bit_vect); + fprintf(stderr, " hp 0x%lx, hplim 0x%lx\n", + (W_) sm->hp, (W_) sm->hplim); + } + + return 0; +} + +I_ +collect2s(reqsize, sm) + W_ reqsize; + smInfo *sm; +{ + I_ root, bstk_roots, caf_roots, extra_caf_words; + PP_ stackptr; + P_ CAFptr, updateFramePtr, caf_start; + + I_ free_space, /* No of words of free space following GC */ + alloc, /* Number of words allocated since last GC */ + resident; /* Number of words remaining after GC */ + + SAVE_REGS(&ScavRegDump); /* Save registers */ + + if (SM_trace) + fprintf(stderr, "Start: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, req %lu\n", + genInfo.semi_space, + (W_) genInfo.space[genInfo.semi_space].base, + (W_) genInfo.space[genInfo.semi_space].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (reqsize * sizeof(W_))); + + alloc = sm->hp - hp_start; + stat_startGC(alloc); + + genInfo.semi_space = NEXT_SEMI_SPACE(genInfo.semi_space); + ToHp = genInfo.space[genInfo.semi_space].base - 1; + Scav = genInfo.space[genInfo.semi_space].base; + OldGen = sm->OldLim; /* always evac ! */ + + DEBUG_STRING("Setting Evac & Upd CAFs:"); + for (CAFptr = sm->CAFlist; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info; + } + +#ifdef PAR + EvacuateLocalGAs(rtsTrue); +#else + evacSPTable( sm ); +#endif /* PAR */ + + DEBUG_STRING("Evacuate Roots:"); + for (root = 0; root < sm->rootno; root++) { + P_ evac = sm->roots[root]; + sm->roots[root] = EVACUATE_CLOSURE(evac); + } + +#if !defined(PAR) + + DEBUG_STRING("Evacuate A Stack:"); + for (stackptr = MAIN_SpA; + SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0; + /* botA points to bottom-most word */ + stackptr = stackptr + AREL(1)) { + P_ evac = *stackptr; + *stackptr = EVACUATE_CLOSURE(evac); + } + DEBUG_STRING("Evacuate B Stack:"); + bstk_roots = 0; + for (updateFramePtr = MAIN_SuB; /* SuB points to topmost update frame */ + SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0; + /* botB points to bottom-most word */ + /* re-initialiser given explicitly */) { + + P_ evac = GRAB_UPDATEE(updateFramePtr); + PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac)); + bstk_roots++; + + updateFramePtr = GRAB_SuB(updateFramePtr); + } +#endif /* PAR */ + + DEBUG_SCAN("Scavenging Start", Scav, "ToHp", ToHp); + while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp); + + DEBUG_STRING("Evacuate & Scavenge CAFs:"); + caf_roots = 0; + caf_start = ToHp; + for (CAFptr = sm->CAFlist; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + + EVACUATE_CLOSURE(CAFptr); /* evac & upd OR return */ + caf_roots++; + + DEBUG_SCAN("Scavenging CAF", Scav, "ToHp", ToHp); + while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + DEBUG_SCAN("Scavenging End", Scav, "ToHp", ToHp); + + /* this_extra_caf_words = ToHp - this_caf_start; */ + /* ToDo: Report individual CAF space */ + } + extra_caf_words = ToHp - caf_start; + +#ifdef PAR + RebuildGAtables(rtsTrue); +#else + reportDeadMallocPtrs( sm->MallocPtrList, NULL, &(sm->MallocPtrList) ); +#endif /* PAR */ + + /* TIDY UP AND RETURN */ + + sm->hp = hp_start = ToHp; /* Last allocated word */ + sm->hplim = genInfo.space[genInfo.semi_space].lim; + + resident = sm->hp - (genInfo.space[genInfo.semi_space].base - 1); + /* DONT_DO_MAX_RESIDENCY -- because this collector is utterly hosed */ + free_space = sm->hplim - sm->hp; + + if (SM_stats_verbose) { + char comment_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s", + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, + caf_roots, extra_caf_words*sizeof(W_), + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1)*sizeof(W_), + (SUBTRACT_B_STK(MAIN_SpB, stackInfo.botB) + 1)*sizeof(W_)); +#else + /* ToDo: come up with some interesting statistics for the parallel world */ + sprintf(comment_str, "%4u %4ld %3ld %3ld %6lu %6lu %6lu 2s", + 0, 0, sm->rootno, caf_roots, extra_caf_words*sizeof(W_), 0, 0); +#endif + stat_endGC(alloc, SM_word_heap_size, resident, comment_str); + } else { + stat_endGC(alloc, SM_word_heap_size, resident, ""); + } + + if (SM_trace) + fprintf(stderr, "Done: space %ld, base 0x%lx, lim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + genInfo.semi_space, + (W_) genInfo.space[genInfo.semi_space].base, + (W_) genInfo.space[genInfo.semi_space].lim, + (W_) sm->hp, (W_) sm->hplim, (W_) (free_space * sizeof(W_))); + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating. */ + TrashMem(sm->hp+1, sm->hplim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + if ((SM_alloc_size > free_space) || (reqsize > free_space)) + return(-1); /* Heap exhausted */ + + return(0); /* Heap OK */ +} + + +I_ +collectHeap(reqsize, sm) + W_ reqsize; + smInfo *sm; +{ + PP_ stackptr, botA; + P_ mutptr, prevmut, updateFramePtr, botB, + CAFptr, prevCAF, oldroot, oldstartToHp, oldstartOldHp, + oldscav, newscav; + I_ root, rootno, bstk_roots, mutable, alloc_cafs, new_cafs, + alloc_oldroots, new_oldroots, old_words; + + I_ bit_words; + P_ oldlim; + PP_ CAFlocs, CAFloc; + + I_ alloc, /* number of words allocated since last GC */ + collect, /* number of words collected */ + promote, /* number of words promoted */ + resident, /* number of words remaining */ + total_resident; /* total number of words remaining after major collection */ + + fflush(stdout); /* Flush stdout at start of GC */ + + if (SM_force_gc == USE_2s) { + return collect2s(reqsize, sm); + } + + + if (reqsize > genInfo.alloc_words) { + fprintf(stderr, "collectHeap: Required size %ld greater then allocation area %ld!\n", + reqsize, genInfo.alloc_words); + fprintf(stderr, " Rerun using +RTS -A<size> to increase allocation area\n"); + EXIT(EXIT_FAILURE); + } + + SAVE_REGS(&ScavRegDump); /* Save registers */ + + if (SM_trace) fprintf(stderr, "GEN Start: hp 0x%lx, hplim 0x%lx, req %ld Minor\n", + (W_) sm->hp, (W_) sm->hplim, (I_) (reqsize * sizeof(W_))); + + alloc = sm->hp - hp_start; + stat_startGC(alloc); + + /* MINOR COLLECTION WITH PROMOTION */ + + collect = alloc + (genInfo.newgen[genInfo.curnew].newlim - genInfo.newgen[genInfo.curnew].newbase + 1); + genInfo.curnew = (genInfo.curnew + 1) % 2; + + ToHp = genInfo.newgen[genInfo.curnew].newbase - 1; + OldGen = genInfo.oldend; /* <= OldGen indicates in the old generation */ + + AllocGen = genInfo.allocbase; /* < AllocGen indicates in delay bucket -> promote */ + OldHp = genInfo.oldlim; + + newscav = genInfo.newgen[genInfo.curnew].newbase; /* Point to (info field of) first closure */ + oldscav = genInfo.oldlim + 1; /* Point to (info field of) first closure */ + + + DEBUG_STRING("Setting Evac & Upd CAFs:"); + for (CAFptr = sm->CAFlist; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info; + } + for (CAFptr = genInfo.NewCAFlist; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + INFO_PTR(CAFptr) = (W_) Caf_Evac_Upd_info; + } + + + /* FIRST: Evacuate and scavenge OldMutable, Roots, AStk & BStk */ + /* Ensure these roots don't use old generation root indirection when evacuated */ + Scav = newscav; + + DEBUG_STRING("Evacuate Roots:"); + for (root = 0, rootno = sm->rootno; root < rootno; root++) { + P_ evac = sm->roots[root]; + if (evac > OldGen) { + sm->roots[root] = EVACUATE_CLOSURE(evac); + } + } + +#if !defined(PAR) + DEBUG_STRING("Evacuate A Stack:"); + for (stackptr = MAIN_SpA, botA = stackInfo.botA; + SUBTRACT_A_STK(stackptr, botA) >= 0; + stackptr = stackptr + AREL(1)) { + P_ evac = *stackptr; + if (evac > OldGen) { + *stackptr = EVACUATE_CLOSURE(evac); + } + } + DEBUG_STRING("Evacuate B Stack:"); + bstk_roots = 0; + for (updateFramePtr = MAIN_SuB, botB = stackInfo.botB; + SUBTRACT_B_STK(updateFramePtr, botB) > 0; + /* re-initialiser given explicitly */) { + + /* Evacuate the thing to be updated */ + P_ evac = GRAB_UPDATEE(updateFramePtr); + if (evac > OldGen) { + PUSH_UPDATEE(updateFramePtr, EVACUATE_CLOSURE(evac)); + } + bstk_roots++; + + updateFramePtr = GRAB_SuB(updateFramePtr); + } +#endif /* PAR */ + + DEBUG_STRING("Evacuate Mutable Roots:"); + mutable = 0; + mutptr = sm->OldMutables; + prevmut = ((P_)&sm->OldMutables) - FIXED_HS; + /* See MUT_LINK */ + while ( mutptr ) { + + /* Scavenge the OldMutable closure */ + P_ info = (P_) INFO_PTR(mutptr); + StgScavPtr scav_code = SCAV_CODE(info); + Scav = mutptr; + (scav_code)(); + + /* Remove from OldMutables if no longer mutable */ + /* HACK ALERT: See comment in SMap.lc + about why we do this terrible pointer comparison. + */ + if (info == ImMutArrayOfPtrs_info) { /* ToDo: use different test? (WDP 94/11) */ + P_ tmp = mutptr; + MUT_LINK(prevmut) = MUT_LINK(mutptr); + mutptr = (P_) MUT_LINK(mutptr); + MUT_LINK(tmp) = MUT_NOT_LINKED; + } else { + prevmut = mutptr; + mutptr = (P_) MUT_LINK(mutptr); + } + mutable++; + } + +#ifdef PAR + EvacuateLocalGAs(rtsFalse); +#else + evacSPTable( sm ); +#endif /* PAR */ + + while ((newscav <= ToHp) || (oldscav <= OldHp)) { + Scav = newscav; + DEBUG_SCAN("Scav: NewScav", Scav, "ToHp", ToHp); + while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + newscav = Scav; + + Scav = oldscav; + DEBUG_SCAN("Scav: OldScav", Scav, "OldHp", OldHp); + while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))(); + oldscav = Scav; + } + + + /* SECOND: Evacuate & Scavenge CAFs and OldGen roots */ + /* Ensure these roots don't use old generation root indirection when evacuated */ + Scav = newscav; + + oldstartToHp = ToHp; + oldstartOldHp = OldHp; + + + DEBUG_STRING("Evacuate CAFs and old generation roots:"); + /* Evacuate CAFs in allocation region to New semispace */ + /* Evacuate CAFs in New semispace to OldGen */ + /* OldCAFlist = NewCAFlist ++ OldCAFlist */ + /* NewCAFlist = CAFlist */ + /* CAFlist = NULL */ + + alloc_cafs = 0; + for (CAFptr = sm->CAFlist; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + EVACUATE_CLOSURE(CAFptr); /* evac & upd */ + alloc_cafs++; + } + + for (CAFptr = genInfo.NewCAFlist, + prevCAF = ((P_)(&genInfo.NewCAFlist)) - FIXED_HS; /* see IND_CLOSURE_LINK */ + CAFptr; CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + EVACUATE_CLOSURE(CAFptr); /* evac & upd */ + prevCAF = CAFptr; + } + new_cafs = genInfo.NewCAFno; + + IND_CLOSURE_LINK(prevCAF) = (W_) genInfo.OldCAFlist; + genInfo.OldCAFlist = genInfo.NewCAFlist; + genInfo.OldCAFno += genInfo.NewCAFno; + + genInfo.NewCAFlist = sm->CAFlist; + genInfo.NewCAFno = alloc_cafs; + sm->CAFlist = NULL; + + + /* Evacuate OldRoots roots to New semispace */ + /* Evacuate OldInNew roots to OldGen, discard these roots */ + /* OldInNew = OldRoots */ + /* OldRoots = 0 */ + + for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) { + P_ evac = (P_) IND_CLOSURE_PTR(oldroot); + if (evac > OldGen) { + IND_CLOSURE_PTR(oldroot) = (W_) EVACUATE_CLOSURE(evac); + } + } + new_oldroots = genInfo.OldInNewno; + + DEBUG_STRING("Scavenge evacuated old generation roots:"); + while ((newscav <= ToHp) || (oldscav <= OldHp)) { + Scav = newscav; + DEBUG_SCAN("Scav: NewScav", Scav, "ToHp", ToHp); + while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + newscav = Scav; + + Scav = oldscav; + DEBUG_SCAN("Scav: OldScav", Scav, "OldHp", OldHp); + while (Scav <= OldHp) (SCAV_CODE(INFO_PTR(Scav)))(); + oldscav = Scav; + } + + old_words = OldHp - oldstartOldHp; /* + (ToHp - oldstartToHp) */ + + + /* record newly promoted mutuple roots */ + MUT_LINK(prevmut) = (W_) genInfo.PromMutables; + genInfo.PromMutables = 0; + + + promote = OldHp - genInfo.oldlim; + resident = (ToHp - genInfo.newgen[genInfo.curnew].newbase + 1) + promote; + + genInfo.newgen[genInfo.curnew].newlim = ToHp; + genInfo.oldlim = OldHp; + + genInfo.minor_since_major++; + +#ifdef PAR + RebuildGAtables(rtsFalse); +#else + reportDeadMallocPtrs(sm->MallocPtrList, + sm->OldMallocPtrList, + &(sm->OldMallocPtrList)); + sm->MallocPtrList = NULL; /* all (new) MallocPtrs have been promoted */ +#endif /* PAR */ + + if (SM_stats_verbose) { + char minor_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(minor_str, "%6lu %4lu %4lu %4ld %3ld %3ld %4ld %3ld %3ld %6ld Minor", + promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots, + (I_) (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, alloc_cafs + new_cafs, + mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_)); +#else + /* ToDo: come up with some interesting statistics for the parallel world */ + sprintf(minor_str, "%6lu %4lu %4lu %4ld %3ld %3ld %4ld %3ld %3ld %6ld Minor", + promote*sizeof(W_), genInfo.OldInNewno - alloc_oldroots, 0, + 0, sm->rootno, alloc_cafs + new_cafs, + mutable, alloc_oldroots, new_oldroots, old_words*sizeof(W_)); +#endif + stat_endGC(alloc, collect, resident, minor_str); + } else { + stat_endGC(alloc, collect, resident, ""); + } + + /* ToDo: Decide to do major early ! */ + + if (genInfo.oldlim <= genInfo.oldthresh && !do_full_collection) { + + sm->hp = hp_start = genInfo.allocbase - 1; + sm->hplim = genInfo.alloclim; + sm->OldLim = genInfo.oldlim; + + if (SM_trace) + fprintf(stderr, "GEN End: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh, + (W_) genInfo.newgen[genInfo.curnew].newbase, + (W_) genInfo.newgen[genInfo.curnew].newlim, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + return GC_SUCCESS; /* Heap OK -- Enough space to continue */ + } + + + DEBUG_STRING("Major Collection Required"); + stat_startGC(0); + + alloc = genInfo.oldlim - genInfo.oldbase + 1; + + /* Zero bit vector for marking phase of major collection */ + + bit_words = (alloc + BITS_IN(BitWord) - 1) / BITS_IN(BitWord); + { BitWord *ptr = genInfo.bit_vect, + *end = genInfo.bit_vect + bit_words; + while (ptr < end) { *(ptr++) = 0; }; + } + + /* Set are for old gen CAFs to be linked */ + + CAFlocs = (PP_) genInfo.newgen[(genInfo.curnew + 1) % 2].newbase; + if (genInfo.new_words < genInfo.OldCAFno) { + fprintf(stderr, "colectHeap: Too many CAFs %ld to link in new semi-space %ld\n", + genInfo.OldCAFno, genInfo.alloc_words); + fprintf(stderr, " Rerun using +RTS -A<size> to increase allocation area\n"); + EXIT(EXIT_FAILURE); + } + + /* Change old generation root indirections to special OldRoot indirections */ + /* These will be marked and not short circuted (like SPEC 2,1 closure) */ + + for (oldroot = genInfo.OldInNew; oldroot; oldroot = (P_) IND_CLOSURE_LINK(oldroot)) { + INFO_PTR(oldroot) = (W_) OldRoot_info; + } + + /* Discard OldInNew roots: Scanning OldRoots will reconstruct live OldInNew root list */ + genInfo.OldInNew = 0; + genInfo.OldInNewno = 0; + + /* Discard OldMutable roots: Scanning Mutables will reconstruct live OldMutables root list */ + sm->OldMutables = 0; + + /* bracket use of MARK_REG_MAP with RESTORE/SAVE of SCAV_REG_MAP */ + RESTORE_REGS(&ScavRegDump); + + markHeapRoots(sm, genInfo.NewCAFlist, genInfo.OldCAFlist, + genInfo.oldbase, genInfo.oldlim, genInfo.bit_vect); + + SAVE_REGS(&ScavRegDump); + /* end of bracket */ + +#ifndef PAR + sweepUpDeadMallocPtrs(sm->OldMallocPtrList, + appelInfo.oldbase, + appelInfo.bits + ); +#endif /* !PAR */ + + oldlim = genInfo.oldlim; + + DEBUG_STRING("Linking Dummy CAF Ptr Locations:"); + CAFloc = CAFlocs; + for (CAFptr = genInfo.OldCAFlist; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + DEBUG_LINK_CAF(CAFptr, CAFloc); + *CAFloc = (P_) IND_CLOSURE_PTR(CAFptr); + LINK_LOCATION_TO_CLOSURE(CAFloc, oldlim); + CAFloc++; + } + + DEBUG_STRING("Linking Roots:"); + for (root = 0; root < sm->rootno; root++) { + LINK_LOCATION_TO_CLOSURE(sm->roots+root, oldlim); + } + +#ifdef PAR + fall over here until we figure out how to link GAs +#else + DEBUG_STRING("Linking Stable Pointer Table:"); + LINK_LOCATION_TO_CLOSURE(&sm->StablePointerTable, oldlim); + DEBUG_STRING("Linking A Stack:"); + for (stackptr = MAIN_SpA; + SUBTRACT_A_STK(stackptr, stackInfo.botA) >= 0; + stackptr = stackptr + AREL(1)) { + LINK_LOCATION_TO_CLOSURE(stackptr, oldlim); + } + DEBUG_STRING("Linking B Stack:"); + for (updateFramePtr = MAIN_SuB; /* SuB points to topmost update frame */ + SUBTRACT_B_STK(updateFramePtr, stackInfo.botB) > 0; + /* re-initialiser given explicitly */) { + + P_ updateClosurePtr = updateFramePtr + BREL(UF_UPDATEE); + LINK_LOCATION_TO_CLOSURE(updateClosurePtr, oldlim); + + updateFramePtr = GRAB_SuB(updateFramePtr); + } +#endif /* PAR */ + + /* Do Inplace Compaction */ + /* Returns start of next closure, -1 gives last allocated word */ + + genInfo.oldlim = Inplace_Compaction(genInfo.oldbase, + genInfo.oldlim, + genInfo.newgen[genInfo.curnew].newbase, + genInfo.newgen[genInfo.curnew].newlim, + genInfo.bit_vect, bit_words) - 1; + + resident = (genInfo.oldlim - genInfo.oldbase) + 1; + total_resident = genInfo.newgen[genInfo.curnew].newlim - + genInfo.newgen[genInfo.curnew].newbase + 1 + resident; + + sm->hp = hp_start = genInfo.allocbase - 1; + sm->hplim = genInfo.alloclim; + sm->OldLim = genInfo.oldlim; + + genInfo.oldwas = genInfo.oldlim; + genInfo.minor_since_major = 0; + + if (SM_stats_verbose) { + char major_str[BIG_STRING_LEN]; +#ifndef PAR + sprintf(major_str, "%6d %4ld %4u %4ld %3ld %3ld %4d %3d %3d %6.6s *Major* %4.1f%%", + 0, genInfo.OldInNewno, + (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) + 1), + bstk_roots, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno, + 0, 0, 0, "", total_resident / (StgFloat) SM_word_heap_size * 100); +#else + sprintf(major_str, "%6d %4ld %4u %4ld %3ld %3ld %4d %3d %3d %6.6s *Major* %4.1f%%", + 0, genInfo.OldInNewno, + 0, 0, sm->rootno, genInfo.NewCAFno + genInfo.OldCAFno, + 0, 0, 0, "", total_resident / (StgFloat) SM_word_heap_size * 100); +#endif + stat_endGC(0, alloc, resident, major_str); + } else { + stat_endGC(0, alloc, resident, ""); + } + + if (SM_trace) + fprintf(stderr, "GEN Major: oldbase 0x%lx, oldlim 0x%lx, oldthresh 0x%lx, newbase 0x%lx, newlim 0x%lx\n hp 0x%lx, hplim 0x%lx, free %lu\n", + (W_) genInfo.oldbase, (W_) genInfo.oldlim, (W_) genInfo.oldthresh, + (W_) genInfo.newgen[genInfo.curnew].newbase, + (W_) genInfo.newgen[genInfo.curnew].newlim, + (W_) sm->hp, (W_) sm->hplim, (W_) (sm->hplim - sm->hp) * sizeof(W_)); + +#ifdef DEBUG + /* To help flush out bugs, we trash the part of the heap from + which we're about to start allocating. */ + TrashMem(sm->hp+1, sm->hplim); +#endif /* DEBUG */ + + RESTORE_REGS(&ScavRegDump); /* Restore Registers */ + + if (genInfo.oldlim > genInfo.oldthresh) + return GC_HARD_LIMIT_EXCEEDED; /* Heap exhausted */ + else + return GC_SUCCESS; /* Heap OK */ +} + +#endif /* GCgn */ + +\end{code} + diff --git a/ghc/runtime/storage/SMinit.lc b/ghc/runtime/storage/SMinit.lc new file mode 100644 index 0000000000..cff23ba7a7 --- /dev/null +++ b/ghc/runtime/storage/SMinit.lc @@ -0,0 +1,185 @@ +\section[storage-manager-init]{Initialising the storage manager} + +To initialise the storage manager, we pass it: +\begin{itemize} +\item +An @argc@/@argv@ combo, which are the command-line arguments that have +been deemed to belong to the runtime system. The initialisation +routine can slurp around in there for information of interest to +it. + +\item +A filehandle to which any storage-manager statistics should be written. +\end{itemize} + +\begin{code} +#define NULL_REG_MAP +#include "SMinternal.h" + +/* global vars to hold some storage-mgr details; */ +/* decls for these are in SMinternal.h */ +I_ SM_force_gc = 0; +I_ SM_word_heap_size = DEFAULT_HEAP_SIZE; +I_ SM_alloc_min = 0; +StgFloat SM_pc_free_heap = DEFAULT_PC_FREE; +I_ SM_alloc_size = 0; +I_ SM_major_gen_size = 0; +I_ SM_word_stk_size = DEFAULT_STACKS_SIZE; +FILE *SM_statsfile = NULL; +I_ SM_trace = 0; +I_ SM_stats_summary = 0; +I_ SM_stats_verbose = 0; +I_ SM_ring_bell = 0; + +I_ MaxResidency = 0; /* in words; for stats only */ +I_ ResidencySamples = 0; /* for stats only */ + +#ifndef atof +extern double atof(); +/* no proto because some machines use const and some do not */ +#endif + +I_ +decode(s) + char *s; +{ + I_ c; + StgDouble m; + if (!*s) + return 0; + m = atof(s); + c = s[strlen(s)-1]; + if (c == 'g' || c == 'G') + m *= 1000*1000*1000; /* UNchecked! */ + else if (c == 'm' || c == 'M') + m *= 1000*1000; /* We do not use powers of 2 (1024) */ + else if (c == 'k' || c == 'K') /* to avoid possible bad effects on */ + m *= 1000; /* a direct-mapped cache. */ + else if (c == 'w' || c == 'W') + m *= sizeof(W_); + return (I_)m; +} + +static void +badoption(s) + char *s; +{ + fflush(stdout); + fprintf(stderr, "initSM: Bad RTS option: %s\n", s); + EXIT(EXIT_FAILURE); +} + +extern long strtol PROTO((const char *, char **, int)); /* ToDo: properly? */ + +I_ +initSM(rts_argc, rts_argv, statsfile) + I_ rts_argc; + char **rts_argv; + FILE *statsfile; +{ + I_ arg; + + /* save statsfile info */ + SM_statsfile = statsfile; + + /* slurp through RTS args */ + + for (arg = 0; arg < rts_argc; arg++) { + if (rts_argv[arg][0] == '-') { + switch(rts_argv[arg][1]) { + case 'H': + SM_word_heap_size = decode(rts_argv[arg]+2) / sizeof(W_); + + if (SM_word_heap_size <= 0) badoption( rts_argv[arg] ); + break; + + case 'M': + SM_pc_free_heap = atof(rts_argv[arg]+2); + + if ((SM_pc_free_heap < 0) || (SM_pc_free_heap > 100)) + badoption( rts_argv[arg] ); + break; + + case 'A': + SM_alloc_size = decode(rts_argv[arg]+2) / sizeof(W_); + + if (SM_alloc_size == 0) SM_alloc_size = DEFAULT_ALLOC_SIZE; + break; + + case 'G': + SM_major_gen_size = decode(rts_argv[arg]+2) / sizeof(W_); + break; + + case 'F': + if (strcmp(rts_argv[arg]+2, "2s") == 0) { + SM_force_gc = USE_2s; + } else if (strcmp(rts_argv[arg]+2, "1s") == 0) { + badoption( rts_argv[arg] ); /* ToDo ! */ + } else { + badoption( rts_argv[arg] ); + } + break; + + case 'K': + SM_word_stk_size = decode(rts_argv[arg]+2) / sizeof(W_); + + if (SM_word_stk_size == 0) badoption( rts_argv[arg] ); + break; + + case 'S': + SM_stats_verbose++; + /* statsfile has already been determined */ + break; + case 's': + SM_stats_summary++; + /* statsfile has already been determined */ + break; + case 'B': + SM_ring_bell++; + break; + + case 'T': + if (rts_argv[arg][2] != '\0') + SM_trace = (I_) strtol(rts_argv[arg]+2, (char **)NULL, 0); + else + SM_trace = 1; + break; + +#ifdef GCdu + case 'u': + dualmodeInfo.resid_to_compact = atof(rts_argv[arg]+2); + dualmodeInfo.resid_from_compact = dualmodeInfo.resid_from_compact + 0.05; + if (dualmodeInfo.resid_from_compact < 0.0 || + dualmodeInfo.resid_to_compact > 1.0) { + badoption( rts_argv[arg] ); + } +#endif + + default: + /* otherwise none of my business */ + break; + } + } + /* else none of my business */ + } + + SM_alloc_min = (I_) (SM_word_heap_size * SM_pc_free_heap / 100); + + return(0); /* all's well */ +} +\end{code} + + +\section[storage-manager-exit]{Winding up the storage manager} + +\begin{code} + +I_ +exitSM (sm_info) + smInfo *sm_info; +{ + stat_exit(sm_info->hp - hp_start); + + return(0); /* I'm happy */ +} +\end{code} diff --git a/ghc/runtime/storage/SMinternal.lh b/ghc/runtime/storage/SMinternal.lh new file mode 100644 index 0000000000..832b5cfedd --- /dev/null +++ b/ghc/runtime/storage/SMinternal.lh @@ -0,0 +1,525 @@ +% +% (c) The AQUA Project, Glasgow University, 1992-1994 +% +\begin{code} +#ifndef SMinternals_H +#define SMinternals_H +\end{code} + +This stuff needs to be documented. KH + +\begin{code} +/* In the Storage Manager we use the global register mapping */ +/* We turn off STG-machine register declarations */ + +#if ! (defined(MAIN_REG_MAP) || defined(NULL_REG_MAP) || defined(MARK_REG_MAP) || defined(SCAN_REG_MAP) || defined(SCAV_REG_MAP)) +**** please set your REG_MAP **** +#endif + +#include "rtsdefs.h" + +#ifdef HAVE_SYS_VADVISE_H +#include <sys/vadvise.h> +#endif + +extern I_ SM_force_gc; +#define USE_2s 1 +#define USE_1s 2 + +extern I_ SM_word_heap_size; /* all defined in SMinit.lc */ +extern I_ SM_alloc_min; +extern StgFloat SM_pc_free_heap; +extern I_ SM_alloc_size; +extern I_ SM_major_gen_size; +/*moved: extern I_ SM_word_stk_size; */ +extern FILE *SM_statsfile; +extern I_ SM_trace; +extern I_ SM_stats_summary; +extern I_ SM_stats_verbose; +extern I_ SM_ring_bell; + +extern P_ heap_space; +extern P_ hp_start; + +extern void stat_init PROTO((char *collector, char *c1, char *c2)); +extern void stat_startGC PROTO((I_ alloc)); +extern void stat_endGC PROTO((I_ alloc, I_ collect, I_ live, char *comment)); +extern void stat_exit PROTO((I_ alloc)); + +extern I_ MaxResidency; /* in words; for stats only */ +extern I_ ResidencySamples; /* for stats only */ + +#define DO_MAX_RESIDENCY(r) /* saves typing */ \ + do { \ + I_ resid = (r); \ + ResidencySamples++; \ + if (resid > MaxResidency) { \ + MaxResidency = resid; \ + } \ + } while (0) + +extern StgFunPtr _Dummy_entry(STG_NO_ARGS); +extern char *xmalloc PROTO((size_t)); + +#if defined(_GC_DEBUG) +#define DEBUG_SCAN(str, pos, to, topos) \ + if (SM_trace & 2) fprintf(stderr, "%s: 0x%lx, %s 0x%lx\n", str, pos, to, topos) +#define DEBUG_STRING(str) \ + if (SM_trace & 2) fprintf(stderr, "%s\n", str) +#else +#define DEBUG_SCAN(str, pos, to, topos) +#define DEBUG_STRING(str) +#endif + +/************************ Default HEAP and STACK sizes **********************/ + +#define DEFAULT_STACKS_SIZE 0x10002 /* 2^16 = 16Kwords = 64Kbytes */ + +#define DEFAULT_HEAP_SIZE 0x100002 /* 2^20 = 1Mwords = 4Mbytes */ +#define DEFAULT_ALLOC_SIZE 0x4002 /* 2^14 = 16k words = 64k bytes */ +#define DEFAULT_PC_FREE 3 /* 3% */ + +/* I added a couple of extra words above, to be more sure of avoiding + bad effects on direct-mapped caches. (WDP) +*/ + +#define NEXT_SEMI_SPACE(space) ((space + 1) % 2) + +/************************ Random stuff **********************/ + +/* This should be really big */ +#define BIG_STRING_LEN 512 + +/************************** TWO SPACE COPYING (2s) **************************/ + +#if defined(GC2s) + +typedef struct { + P_ base; /* First word allocatable in semispace */ + P_ lim; /* Last word allocatable in semispace */ +} semispaceData; + +extern I_ semispace; /* 0 or 1 -- indexes semispaceInfo */ +extern semispaceData semispaceInfo[2]; + +#endif /* GC2s */ + + +/*********************** SINGLE SPACE COMPACTION (1s) ***********************/ + +#if defined(GC1s) + +typedef struct { + P_ base; /* First word allocatable in heap */ + P_ lim; /* Last word allocatable in heap */ + BitWord *bits; /* Area for marking bits */ + I_ bit_words; /* Size of marking bit area (in words) */ + I_ heap_words; /* Size of heap area (in words) */ +} compactingData; + +extern compactingData compactingInfo; + +#endif /* GC1s */ + + +/****************************** DUAL MODE (du) ******************************/ + +#if defined(GCdu) + +typedef struct { + I_ mode; + StgFloat resid_to_compact; + StgFloat resid_from_compact; + struct { + P_ base; /* First word allocatable in this mode */ + P_ lim; /* Last word allocatable in this mode */ + I_ heap_words; /* Size of area (in words) */ + char *name; + } modeinfo[3]; + BitWord *bits; /* Area for marking bits */ + I_ bit_words; /* Size of marking bit area (in words) */ +} dualmodeData; + +extern dualmodeData dualmodeInfo; + +#define DEFAULT_RESID_TO_COMPACT 0.25 +#define DEFAULT_RESID_FROM_COMPACT 0.20 + +#define TWO_SPACE_BOT 0 +#define TWO_SPACE_TOP 1 +#define COMPACTING 2 + +#endif /* GCdu */ + +/*************************** APPELS COLLECTOR (ap) **************************/ + +#if defined(GCap) + +typedef struct { + P_ oldbase; /* first word allocatable in oldgen */ + P_ oldlim; /* last word allocated in oldgen */ + P_ oldlast; /* oldlim after last major collection */ + P_ oldthresh; /* threshold of oldgen occupancy */ + P_ oldmax; /* maximum allocatable in oldgen before heap deemed full */ + + I_ newfixed; /* The size of the new generation, if fixed */ + I_ newmin; /* The minimum size of the new generation */ + P_ newbase; /* First word allocatable in newgen top space */ + P_ newlim; /* Last word allocatable in newgen top space */ + + BitWord *bits; /* Area for marking bits */ + + P_ OldCAFlist; /* CAFs promoted to old generation */ + I_ OldCAFno; /* No of CAFs promoted to old generation */ + I_ bit_words; /* Size of marking bit area (in words) */ + + P_ PromMutables; /* List of recently promoted mutable closures */ + + I_ semi_space; /* -F forced 2s collector */ + struct { + P_ base; /* First word allocatable in semispace */ + P_ lim; /* Last word allocatable in semispace */ + } space[2]; + +} appelData; + +/* UPDATE INFO - Stored in sm info structure: + Additional info required when updating to keep track of + new generation roots residing in the old generation + (old -> new inter-generation pointers) +*/ + +extern appelData appelInfo; + +#endif /* GCap */ + + +/************************ GENERATIONAL COLLECTOR (gn) ***********************/ + +#if defined(GCgn) + +typedef struct { + I_ alloc_words; /* Size of allocation space */ + /* May be large enough for bit array */ + I_ new_words; /* Size of new generation semi-space */ + /* Must be large enough for bit array */ + I_ old_words; /* Size of old generation */ + + I_ minor_since_major; + /* No of minor collections since last major */ + + P_ allocbase; /* First word allocatable in oldgen */ + P_ alloclim; /* Last word allocatable in oldgen */ + + I_ curnew; /* New gen semi-space currently in use */ + struct { + P_ newbase; /* First word allocatable in newgen semispace */ + P_ newlim; /* Last word allocated in new semi-space */ + } newgen[2]; + + P_ oldbase; /* First word allocatable in oldgen */ + P_ oldend; /* Last word allocatable in oldgen */ + P_ oldwas; /* Limit of oldgen after last major collection */ + P_ oldlim; /* Last word allocated in oldgen */ + P_ oldthresh; /* Oldgen threshold: less than new_words free */ + BitWord *bit_vect; /* Marking bits -- alloc area or old generation */ + + P_ OldInNew; /* Old roots pointing to new generation */ + I_ OldInNewno; /* No of Old roots pointing to new generation */ + P_ NewCAFlist; /* CAFs in new generation */ + I_ NewCAFno; /* No of CAFs in new generation */ + P_ OldCAFlist; /* CAFs promoted to old generation */ + I_ OldCAFno; /* No of CAFs promoted to old generation */ + + P_ PromMutables; /* List of recently promoted mutable closures */ + + I_ semi_space; /* -F forced 2s collector */ + struct { + P_ base; /* First word allocatable in semispace */ + P_ lim; /* Last word allocatable in semispace */ + } space[2]; +} genData; + +extern genData genInfo; + +/* Update INFO - Stored in sm info structure: + Additional info required when updating to keep track of + new generation roots residing in the old generation + (old -> new inter-generation pointers) +*/ + +#endif /* GCap */ + +/****************************** COPYING ******************************/ + + +#if defined(_INFO_COPYING) + +#define EVAC_CODE(infoptr) ((StgEvacPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET]) +#define SCAV_CODE(infoptr) ((StgScavPtr) ((P_)(INFO_RTBL(infoptr)))[COPY_INFO_OFFSET+1]) + +extern void Scavenge(STG_NO_ARGS); +extern void _Scavenge_Forward_Ref(STG_NO_ARGS); + +/* Note: any change to FORWARD_ADDRESS should be + reflected in layout of MallocPtrs (includes/SMClosures.lh) +*/ + +#define FORWARD_ADDRESS(closure) (*(((P_)(closure)) + FIXED_HS)) + +#define FORWARDREF_ITBL(infolbl,entry,localness,evac_forward) \ +CAT_DECLARE(infolbl,INTERNAL_KIND,"FORWARD_REF","FORWARD_REF") \ +localness W_ infolbl[] = { \ + (W_) entry \ + ,(W_) INFO_OTHER_TAG \ + ,(W_) MK_REP_REF(,evac_forward,) \ + INCLUDE_PROFILING_INFO(infolbl) \ + } + +P_ _Evacuate_Old_Forward_Ref PROTO((P_)); +P_ _Evacuate_New_Forward_Ref PROTO((P_)); +P_ _Evacuate_OldRoot_Forward PROTO((P_)); +P_ _Evacuate_Forward_Ref PROTO((P_)); + +MAYBE_DECLARE_RTBL(,_Evacuate_Old_Forward_Ref,) +MAYBE_DECLARE_RTBL(,_Evacuate_New_Forward_Ref,) +MAYBE_DECLARE_RTBL(,_Evacuate_OldRoot_Forward,) +MAYBE_DECLARE_RTBL(,_Evacuate_Forward_Ref,) + +#define FORWARDREF_RTBL(evac_forward) \ + const W_ MK_REP_LBL(,evac_forward,)[] = { \ + INCLUDE_TYPE_INFO(INTERNAL) \ + INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \ + INCLUDE_PAR_INFO \ + INCLUDE_COPYING_INFO(evac_forward,_Scavenge_Forward_Ref)\ + INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \ + } + +EXTDATA_RO(Caf_Evac_Upd_info); +extern StgEvacFun _Evacuate_Caf_Evac_Upd; + +#define CAF_EVAC_UPD_ITBL(infolbl,entry,localness) \ +CAT_DECLARE(infolbl,INTERNAL_KIND,"CAF_EVAC_UPD","CAF_EVAC_UPD") \ +localness W_ infolbl[] = { \ + (W_) entry \ + ,(W_) INFO_OTHER_TAG \ + ,(W_) MK_REP_REF(Caf_Evac_Upd,,) \ + INCLUDE_PROFILING_INFO(infolbl) \ + } + +MAYBE_DECLARE_RTBL(Caf_Evac_Upd,,) + +#define CAF_EVAC_UPD_RTBL() \ + const W_ MK_REP_LBL(Caf_Evac_Upd,,)[] = { \ + INCLUDE_TYPE_INFO(INTERNAL) \ + INCLUDE_SIZE_INFO(MIN_UPD_SIZE,INFO_UNUSED) \ + INCLUDE_PAR_INFO \ + INCLUDE_COPYING_INFO(_Evacuate_Caf_Evac_Upd,_Scavenge_Caf) \ + INCLUDE_COMPACTING_INFO(INFO_UNUSED,INFO_UNUSED,INFO_UNUSED,INFO_UNUSED) \ + } + +#define EVACUATE_CLOSURE(closure) \ + (EVAC_CODE(INFO_PTR(closure)))(closure) + +#endif /* _INFO_COPYING */ + + +/****************************** MARKING ******************************/ + +#if defined(_INFO_MARKING) + +extern I_ markHeapRoots PROTO((smInfo *sm, P_ cafs1, P_ cafs2, + P_ base, P_ lim, BitWord *bit_array)); + +#define PRMARK_CODE(infoptr) \ + (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+1]) + +/* Applied to unmarked or marking info pointer */ +#define PRRETURN_CODE(infoptr) \ + (((FP_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+3]) + +/* This placed on bottom of PR Marking Stack */ + +#define DUMMY_PRRETURN_CLOSURE(closure_name, table_name, prreturn_code, dummy_code) \ +const W_ table_name[] = { \ + (W_) dummy_code \ + ,(W_) INFO_OTHER_TAG \ + ,(W_) MK_REP_REF(,prreturn_code,) \ + INCLUDE_PROFILING_INFO(Dummy_PrReturn) \ + }; \ +W_ closure_name = (W_) table_name + +EXTFUN(_Dummy_PRReturn_entry); +EXTFUN(_PRMarking_MarkNextRoot); +EXTFUN(_PRMarking_MarkNextCAF); + +#ifdef CONCURRENT +EXTFUN(_PRMarking_MarkNextSpark); +#endif + +#ifdef PAR +EXTFUN(_PRMarking_MarkNextGA); +MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextGA,) +#else + +EXTFUN(_PRMarking_MarkNextAStack); +EXTFUN(_PRMarking_MarkNextBStack); + +MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextAStack,) +MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextBStack,) + +#endif /* PAR */ + +#ifdef CONCURRENT +MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextSpark,) +#endif + +MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextRoot,) +MAYBE_DECLARE_RTBL(,_PRMarking_MarkNextCAF,) + +#define DUMMY_PRRETURN_RTBL(prreturn_code,dummy_code) \ + const W_ MK_REP_LBL(,prreturn_code,)[] = { \ + INCLUDE_TYPE_INFO(INTERNAL) \ + INCLUDE_SIZE_INFO(INFO_UNUSED,INFO_UNUSED) \ + INCLUDE_PAR_INFO \ + INCLUDE_COPYING_INFO(dummy_code,dummy_code) \ + INCLUDE_COMPACTING_INFO(dummy_code,dummy_code,dummy_code,prreturn_code) \ + } + +/* Unused "Code to avoid explicit updating of CAF references" used to live here + (WDP 94/11) +*/ + +#endif /* _INFO_MARKING */ + + +/****************************** COMPACTING ******************************/ + +#if defined(_INFO_COMPACTING) + +#ifndef PAR +P_ Inplace_Compaction PROTO((P_ base, P_ lim, + P_ scanbase, P_ scablim, + BitWord *bit_array, I_ bit_array_words, + StgPtr *MallocPtrList)); +#else +P_ Inplace_Compaction PROTO((P_ base, P_ lim, + P_ scanbase, P_ scablim, + BitWord *bit_array, I_ bit_array_words)); +#endif +/* Applied to marked info pointers */ + +#define SCAN_LINK_CODE(infoptr) \ + ((StgScanPtr) ((P_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET]) +#define SCAN_MOVE_CODE(infoptr) \ + ((StgScanPtr) ((P_)(INFO_RTBL(infoptr)))[COMPACTING_INFO_OFFSET+2]) + +/* + This fragment tests whether we're in global garbage collection during parallel + evaluation. If so, then we check the global address of the closure \tr{loc} + and evacuate it in the IMUs if it's a legal global address. +*/ + +#define LINK_GLOBALADDRESS(loc) + +#if defined(GCgn) + +extern StgScavFun _Scavenge_OldRoot; /* Allocated Old -> New root, just skip */ +extern StgEvacFun _Evacuate_OldRoot; /* Should not occur */ + +extern StgFunPtr _PRStart_OldRoot(STG_NO_ARGS); /* Marking old root -- Short circut if points to oldgen */ +extern StgScanFun _ScanMove_OldRoot; /* Scanning old root -- Rebuild old root list */ + +EXTDATA_RO(OldRoot_info); + +#define OLDROOT_ITBL(infolbl,ind_code,localness,entry_localness)\ + CAT_DECLARE(infolbl,INTERNAL_KIND,"OLDROOT","OLDROOT") \ + entry_localness(ind_code); \ + localness W_ infolbl[] = { \ + (W_) ind_code \ + ,(W_) INFO_OTHER_TAG \ + ,(W_) MK_REP_REF(OldRoot,,) \ + INCLUDE_PROFILING_INFO(infolbl) \ + } + +MAYBE_DECLARE_RTBL(OldRoot,,) + +#define OLDROOT_RTBL() \ + const W_ MK_REP_LBL(OldRoot,,)[] = { \ + INCLUDE_TYPE_INFO(SPEC_U) \ + INCLUDE_SIZE_INFO(2,1) /* deeply hardwired size/ptrs */ \ + INCLUDE_PAR_INFO \ + INCLUDE_COPYING_INFO(_Evacuate_OldRoot,_Scavenge_OldRoot) \ + SPEC_COMPACTING_INFO(_ScanLink_2_1,_PRStart_OldRoot,_ScanMove_OldRoot,_PRIn_1) \ + } + +#define LINK_LOCATION_TO_CLOSURE(loc,linklim) \ + { P_ _temp = (P_) *(loc); \ + DEBUG_LINK_LOCATION(loc, _temp, linklim); \ + if (DYNAMIC_CLOSURE(_temp) && (_temp <= linklim)) { \ + *((P_)(loc)) = (W_) INFO_PTR(_temp); \ + INFO_PTR(_temp) = MARK_LOCATION(loc); \ + }} + +#else /* ! GCgn */ + +#define LINK_LOCATION_TO_CLOSURE(loc) \ + { P_ _temp = (P_) *(loc); \ + DEBUG_LINK_LOCATION(loc, _temp); \ + if (DYNAMIC_CLOSURE(_temp)) { \ + *((P_)(loc)) = (W_) INFO_PTR(_temp); \ + INFO_PTR(_temp) = MARK_LOCATION(loc); \ + }} + +#endif /* ! GCgn */ + +#if defined(_GC_DEBUG) + +#if defined(GCgn) +#define DEBUG_LINK_LOCATION(location, closure, linklim) \ + if (SM_trace & 4) { \ + if (DYNAMIC_CLOSURE(closure) && (closure <= linklim)) \ + fprintf(stderr, " Link Loc: 0x%lx to 0x%lx\n", location, closure); \ + else if (! DYNAMIC_CLOSURE(closure)) \ + fprintf(stderr, " Link Loc: 0x%lx to 0x%lx Static Closure -- Not Done\n", location, closure); \ + else \ + fprintf(stderr, " Link Loc: 0x%lx to 0x%lx OutOfRange Closure -- Not Done\n", location, closure); \ + } +#else /* ! GCgn */ +#define DEBUG_LINK_LOCATION(location, closure) \ + if (SM_trace & 4) { \ + if (DYNAMIC_CLOSURE(closure)) \ + fprintf(stderr, " Link Loc: 0x%lx to 0x%lx\n", location, closure); \ + else \ + fprintf(stderr, " Link Loc: 0x%lx to 0x%lx Static Closure -- Not Done\n", location, closure); \ + } +#endif /* ! GCgn */ + +#define DEBUG_UNLINK_LOCATION(location, closure, newlocation) \ + if (SM_trace & 4) \ + fprintf(stderr, " UnLink Loc: 0x%lx, 0x%lx -> 0x%lx\n", location, closure, newlocation) + +#define DEBUG_LINK_CAF(caf) \ + if (SM_trace & 4) \ + fprintf(stderr, "Caf: 0x%lx Closure: 0x%lx\n", caf, IND_CLOSURE_PTR(caf)) + +#define DEBUG_SET_MARK(closure, hp_word) \ + if (SM_trace & 8) \ + fprintf(stderr, " Set Mark Bit: 0x%lx, word %ld, bit_word %ld, bit %d\n", closure, hp_word, hp_word / BITS_IN(BitWord), hp_word & (BITS_IN(BitWord) - 1)) + +#else +#if defined(GCgn) +#define DEBUG_LINK_LOCATION(location, closure, linklim) +#else +#define DEBUG_LINK_LOCATION(location, closure) +#endif +#define DEBUG_UNLINK_LOCATION(location, closure, newlocation) +#define DEBUG_LINK_CAF(caf) +#define DEBUG_SET_MARK(closure, hp_word) +#endif + +#endif /* _INFO_COMPACTING */ + +#endif /* SMinternals_H */ + +\end{code} diff --git a/ghc/runtime/storage/SMmark.lhc b/ghc/runtime/storage/SMmark.lhc new file mode 100644 index 0000000000..ae6a3fab8e --- /dev/null +++ b/ghc/runtime/storage/SMmark.lhc @@ -0,0 +1,1628 @@ +%**************************************************************************** +% +\section[SMmark.lhc]{Pointer-Reversing Mark code} +% +% (c) P. Sansom, K. Hammond, OBFUSCATION-THROUGH-GRATUITOUS-PREPROCESSOR-ABUSE +% Project, Glasgow University, January 26th 1993. +% +%**************************************************************************** + +This module contains the specialised and generic code to perform +pointer reversal marking. These routines are placed in the info +tables of the appropriate closures. + +Some of the dirt is hidden in macros defined in SMmarkDefs.lh. + +%**************************************************************************** +% +\subsection[mark-overview]{Overview of Marking} +% +%**************************************************************************** + +This module uses a pointer-reversal algorithm to mark a closure. +To mark a closure, first set a bit indicating that the closure +has been marked, then mark each pointer in the closure. The mark +bit is used to determine whether a node has already been +marked before we mark it. Because we set the bit before marking +the children of a node, this avoids cycles. + +Given a closure containing a number of pointers, $n$, $n > 0$ the mark +code for that closure can be divided into three parts: +\begin{enumerate} +\item +The mark (or ``start'') code for the closure. Called when an attempt is made +to mark the closure, it initialises the mark position in the +closure, then jumps to the mark code for the first pointer. +\item +The return (or ``in'') code for the closure. Called when a closure is +returned to after a child is marked, it increments the mark position +and jumps to the mark entry for the next pointer +\item +The last (or ``in-last'') code for the closure. Called when all children +have been marked, it just returns to its parent through the appropriate +return code. +\end{enumerate} + +For non-\tr{SPEC} closures, the return and last codes are merged in most +cases, so the return code checks explicitly whether all pointers have +been marked, and returns if so. + +%**************************************************************************** +% +\subsubsection[mark-registers]{Registers used when marking} +% +%**************************************************************************** + +Two registers are used: +\begin{description} +\item[Mark] +Points to the closure being marked. +\item[MStack] +Points to the closure on the top of the marking stack. +The first closure on the stack contains the continuation to +enter when marking is complete. +\end{description} + +The following registers are used by Pointer Reversal Marking: + +\begin{description} +\item[@MStack@] +The top of the mark stack. +\item[@Mark@] +The node being processed. +\item[@BitArray@] +The bit array (what's that? KH) to mark. +\item[@HeapBase@] +The base of the heap (to calculate bit to mark). +\item[@HeapLim@] +The limit of the heap. For generational garbage collection, +only closures whose address is $<$ @HeapLim@ will be marked +\end{description} + +To answer KH's question, the @BitArray@ is used to store marks. This +avoids the need to include space for a mark bit in the closure itself. +The array consists of one bit per word of heap memory that is handled +by the compacting collector or the old generation in the generational +collector. [ADR] + +%**************************************************************************** +% +\subsubsection[mark-conventions]{Calling and Return Conventions} +% +%**************************************************************************** + +When a child closure is returned from, the registers have the following +values. + +\begin{description} +\item[@Mark@] +points to the closure just marked (this may be updated with a new +address to short-circuit indirections). +\item[MStack] +points to the closure whose return code has been entered +(this closure is now at the top of the pointer-reversal marking stack). +\end{description} + +The macros @JUMP_MARK@ and @JUMP_MARK_RETURN@ jump to the start code +pointed to by the @Mark@ register, or the return code pointed to by +the @MStack@ register respectively. + + +%%%% GOT THIS FAR -- KH %%%% + +Marking A Closure: + @_PRStart_N@ + + Retrieved using PRMARK_CODE(infoptr) + +Uses pointer reversal marking to mark a closure which contains N ptrs. +If the closure has 0 pointers it sets it to a marked state and returns +to the closure on top of the PR mark stack (_PRStart_0). + +If Not (@_PRStart_N@ ($N > 0$)) + sets to a state of marking the first pointer + pushes this closure on the PR marking stack (in the first ptr location) + marks the first child -- enters its marking code + +A closure that is already marked just indicates this by returning to the +closure on the top of the PR mark stack. + + Calling Conventions: + Mark -- points to the closure to mark + MStack -- points to the closure on the top of the PR marking stack + If the stack is empty it points to a closure which contains + the continuation to enter when marking is complete. + + User Invokation: + Have root to mark + MStack set to a closure containing the continuation to be called when + the root has been marked. + Mark pointing to the closure + + Entering MStack Continuation: + Mark points to new value of the closure (indirection short circut) + *** Update root being marked with this value. + + +Returning To A Closure Being Marked: + _PRIn_I + _PRInLast_N + + Retrieved using PRRETURN_CODE(infoptr) + +Starts marking the next pointer (_PRIn_I). + updates the current poointer being marked with new Mark + sets state to next pointer + marks the next child +If not, (_PRInLast_N), it returns to the closure on the top of the PR +marking stack. + + Calling Conventions: + Mark -- points to the closure just marked (may be updated with new + address to short indirections) + MStack -- points to it -- the closure on the top of the PR marking stack + + + +The following registers are used by Pointer Reversal Marking: + +MStack -- The MarkStack register +Mark -- Points to the Node being processed +BitArray -- The bit array to mark +HeapBase -- The base of the heap (to calculate bit to mark) +HeapLim -- The limit of the heap + -- For gen gc: only closures < HeapLim will be marked + -- OldRoots pointing < HeapLim + +\input{SMmarkDefs.lh} + +%**************************************************************************** +% +\subsection[mark-code]{The actual Marking Code} +% +%**************************************************************************** + +This code is only used if @_INFO_MARKING@ is defined. + +\begin{code} +#if defined(_INFO_MARKING) +\end{code} + +First the necessary forward declarations. + +\begin{code} +/* #define MARK_REG_MAP -- Must be done on command line for threaded code */ +#include "SMinternal.h" +#include "SMmarkDefs.h" +\end{code} + +Define appropriate variables as potential register variables. +Assume GC code saves and restores any global registers used. + +\begin{code} +RegisterTable MarkRegTable; +\end{code} + +@_startMarkWorld@ restores registers if necessary, then marks the +root pointed to by @Mark@. + +\begin{code} +STGFUN(_startMarkWorld) +{ + FUNBEGIN; +#if defined(__STG_GCC_REGS__) && defined(__GNUC__) + /* If using registers load from _SAVE (see SMmarking.lc) */ + + /* I deeply suspect this should be RESTORE_REGS(...) [WDP 95/02] */ +#ifdef REG_MarkBase + MarkBaseReg = &MarkRegTable; +#endif + Mark = SAVE_Mark; + MRoot = SAVE_MRoot; + MStack = SAVE_MStack; + BitArray = SAVE_BitArray; + HeapBase = SAVE_HeapBase; + HeapLim = SAVE_HeapLim; +#endif + + JUMP_MARK; + FUNEND; +} +\end{code} + +This is the pointer reversal start code for \tr{SPEC} closures with 0 +pointers. + +\begin{code} +STGFUN(_PRStart_0) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + } else + INIT_MARK_NODE("SPEC",0); + + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + + +This macro defines the format of the pointer reversal start code for a +number of pointers \tr{ptrs}, $>$ 0. + +\begin{code} + +#define SPEC_PRStart_N_CODE(ptrs) \ +STGFUN(CAT2(_PRStart_,ptrs)) \ +{ \ + FUNBEGIN; \ + if (IS_MARK_BIT_SET(Mark)) { \ + DEBUG_PR_MARKED; \ + JUMP_MARK_RETURN; \ + } else { \ + INIT_MARK_NODE("SPEC",ptrs); \ + INIT_MSTACK(SPEC_CLOSURE_PTR); \ + } \ + FUNEND; \ +} + +\end{code} + +The definitions of the start code for \tr{SPEC} closures with 1-12 +pointers. + +\begin{code} +SPEC_PRStart_N_CODE(1) +SPEC_PRStart_N_CODE(2) +SPEC_PRStart_N_CODE(3) +SPEC_PRStart_N_CODE(4) +SPEC_PRStart_N_CODE(5) +SPEC_PRStart_N_CODE(6) +SPEC_PRStart_N_CODE(7) +SPEC_PRStart_N_CODE(8) +SPEC_PRStart_N_CODE(9) +SPEC_PRStart_N_CODE(10) +SPEC_PRStart_N_CODE(11) +SPEC_PRStart_N_CODE(12) + +\end{code} + +Start code for revertible black holes with underlying @SPEC@ types. + +\begin{code} + +#ifdef PAR +#define SPEC_RBH_PRStart_N_CODE(ptrs) \ +STGFUN(CAT2(_PRStart_RBH_,ptrs)) \ +{ \ + FUNBEGIN; \ + if (IS_MARK_BIT_SET(Mark)) { \ + DEBUG_PR_MARKED; \ + JUMP_MARK_RETURN; \ + } else { \ + INIT_MARK_NODE("SRBH",ptrs-1); \ + INIT_MSTACK(SPEC_RBH_CLOSURE_PTR); \ + } \ + FUNEND; \ +} + +SPEC_RBH_PRStart_N_CODE(2) +SPEC_RBH_PRStart_N_CODE(3) +SPEC_RBH_PRStart_N_CODE(4) +SPEC_RBH_PRStart_N_CODE(5) +SPEC_RBH_PRStart_N_CODE(6) +SPEC_RBH_PRStart_N_CODE(7) +SPEC_RBH_PRStart_N_CODE(8) +SPEC_RBH_PRStart_N_CODE(9) +SPEC_RBH_PRStart_N_CODE(10) +SPEC_RBH_PRStart_N_CODE(11) +SPEC_RBH_PRStart_N_CODE(12) + +#endif + +\end{code} + +@SPEC_PRIn_N_CODE@ has two different meanings, depending on the world +in which we use it: +\begin{itemize} +\item +In the commoned-info-table world, it +defines the ``in'' code for a particular number +of pointers, and subsumes the functionality of @SPEC_PRInLast_N_NODE@ below. +\item +Otherwise, it defines the ``in'' code for a particular pointer in a +\tr{SPEC} closure. +\end{itemize} + +\begin{code} + +#define SPEC_PRIn_N_CODE(ptrs) \ +STGFUN(CAT2(_PRIn_,ptrs)) \ +{ \ + BitWord mbw; \ + FUNBEGIN; \ + GET_MARKED_PTRS(mbw,MStack,ptrs); \ + if (++mbw < ptrs) { \ + SET_MARKED_PTRS(MStack,ptrs,mbw); \ + CONTINUE_MARKING_NODE("SPEC",mbw); \ + MOVE_TO_NEXT_PTR(SPEC_CLOSURE_PTR,mbw); \ + } else { \ + SET_MARKED_PTRS(MStack,ptrs,0L); \ + POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,ptrs); \ + } \ + FUNEND; \ +} + +\end{code} + +Now @SPEC_PRIn_N_CODE@ is used to define the individual entries for \tr{SPEC} closures +with 1-12 pointers. + +\begin{code} +STGFUN(_PRIn_0) +{ + FUNBEGIN; + fprintf(stderr,"Called _PRIn_0\nShould never occur!\n"); + abort(); + FUNEND; +} +STGFUN(_PRIn_1) +{ + FUNBEGIN; + POP_MSTACK("SPEC",SPEC_CLOSURE_PTR,1); + FUNEND; +} +SPEC_PRIn_N_CODE(2) +SPEC_PRIn_N_CODE(3) +SPEC_PRIn_N_CODE(4) +SPEC_PRIn_N_CODE(5) +SPEC_PRIn_N_CODE(6) +SPEC_PRIn_N_CODE(7) +SPEC_PRIn_N_CODE(8) +SPEC_PRIn_N_CODE(9) +SPEC_PRIn_N_CODE(10) +SPEC_PRIn_N_CODE(11) +SPEC_PRIn_N_CODE(12) +\end{code} + +In code for revertible black holes with underlying @SPEC@ types. + +\begin{code} +#ifdef PAR +#define SPEC_RBH_PRIn_N_CODE(ptrs) \ +STGFUN(CAT2(_PRIn_RBH_,ptrs)) \ +{ \ + BitWord mbw; \ + FUNBEGIN; \ + GET_MARKED_PTRS(mbw,MStack,ptrs-1); \ + if (++mbw < ptrs-1) { \ + SET_MARKED_PTRS(MStack,ptrs-1,mbw); \ + CONTINUE_MARKING_NODE("SRBH",mbw); \ + MOVE_TO_NEXT_PTR(SPEC_RBH_CLOSURE_PTR,mbw); \ + } else { \ + SET_MARKED_PTRS(MStack,ptrs-1,0L); \ + POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,ptrs-1); \ + } \ + FUNEND; \ +} + +STGFUN(_PRIn_RBH_2) +{ + FUNBEGIN; + POP_MSTACK("SRBH",SPEC_RBH_CLOSURE_PTR,1); + FUNEND; +} + +SPEC_RBH_PRIn_N_CODE(3) +SPEC_RBH_PRIn_N_CODE(4) +SPEC_RBH_PRIn_N_CODE(5) +SPEC_RBH_PRIn_N_CODE(6) +SPEC_RBH_PRIn_N_CODE(7) +SPEC_RBH_PRIn_N_CODE(8) +SPEC_RBH_PRIn_N_CODE(9) +SPEC_RBH_PRIn_N_CODE(10) +SPEC_RBH_PRIn_N_CODE(11) +SPEC_RBH_PRIn_N_CODE(12) +#endif + +\end{code} + +Malloc Ptrs are in the sequential world only. + +\begin{code} + +#ifndef PAR + +STGFUN(_PRStart_MallocPtr) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + } else + INIT_MARK_NODE("MallocPtr ",0); + JUMP_MARK_RETURN; + FUNEND; +} +#endif /* !PAR */ +\end{code} + +This defines the start code for generic (\tr{GEN}) closures. + +\begin{code} +STGFUN(_PRStart_N) +{ + W_ ptrs; + + FUNBEGIN; + + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } + ptrs = GEN_CLOSURE_NoPTRS(Mark); + INIT_MARK_NODE("GEN ",ptrs); + if (ptrs == 0) { + JUMP_MARK_RETURN; + } else { + INIT_MSTACK(GEN_CLOSURE_PTR); + } + FUNEND; +} +\end{code} + +Now the ``in'' code for \tr{GEN} closures. + +\begin{code} +STGFUN(_PRIn_I) +{ + W_ ptrs; + BitWord pos; + + FUNBEGIN; + + ptrs = GEN_CLOSURE_NoPTRS(MStack); + GET_GEN_MARKED_PTRS(pos,MStack,ptrs); + + if (++pos < ptrs) { + SET_GEN_MARKED_PTRS(MStack,ptrs,pos); + CONTINUE_MARKING_NODE("GEN",pos); + MOVE_TO_NEXT_PTR(GEN_CLOSURE_PTR,pos); + } else { + SET_GEN_MARKED_PTRS(MStack,ptrs,0L); + POP_MSTACK("GEN ",GEN_CLOSURE_PTR,ptrs); + } + FUNEND; +} +\end{code} + +And the start/in code for a revertible black hole with an underlying @GEN@ closure. + +\begin{code} + +#ifdef PAR + +STGFUN(_PRStart_RBH_N) +{ + W_ ptrs; + + FUNBEGIN; + + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } + + /* + * Get pointer count from original closure and adjust for one pointer + * in the first two words of the RBH. + */ + ptrs = GEN_RBH_CLOSURE_NoPTRS(Mark); + if (ptrs < 2) + ptrs = 1; + else + ptrs--; + + INIT_MARK_NODE("GRBH", ptrs); + INIT_MSTACK(GEN_RBH_CLOSURE_PTR); + FUNEND; +} + +STGFUN(_PRIn_RBH_I) +{ + W_ ptrs; + BitWord pos; + + FUNBEGIN; + + /* + * Get pointer count from original closure and adjust for one pointer + * in the first two words of the RBH. + */ + ptrs = GEN_RBH_CLOSURE_NoPTRS(MStack); + if (ptrs < 2) + ptrs = 1; + else + ptrs--; + + GET_GEN_MARKED_PTRS(pos, MStack, ptrs); + + if (++pos < ptrs) { + SET_GEN_MARKED_PTRS(MStack, ptrs, pos); + CONTINUE_MARKING_NODE("GRBH", pos); + MOVE_TO_NEXT_PTR(GEN_RBH_CLOSURE_PTR, pos); + } else { + SET_GEN_MARKED_PTRS(MStack, ptrs, 0L); + POP_MSTACK("GRBH", GEN_RBH_CLOSURE_PTR, ptrs); + } + FUNEND; +} + +#endif + +\end{code} + +Start code for dynamic (\tr{DYN}) closures. There is no \tr{DYN} +closure with 0 pointers -- \tr{DATA} is used instead. + +\begin{code} +STGFUN(_PRStart_Dyn) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("DYN ", DYN_CLOSURE_NoPTRS(Mark)); + INIT_MSTACK(DYN_CLOSURE_PTR); + } + FUNEND; +} +\end{code} + +and the corresponding ``in'' code. + +\begin{code} +STGFUN(_PRIn_I_Dyn) +{ + W_ ptrs; + BitWord pos; + + FUNBEGIN; + ptrs = DYN_CLOSURE_NoPTRS(MStack); + GET_GEN_MARKED_PTRS(pos,MStack,ptrs); + + if (++pos < ptrs) { + SET_GEN_MARKED_PTRS(MStack,ptrs,pos); + CONTINUE_MARKING_NODE("DYN",pos); + MOVE_TO_NEXT_PTR(DYN_CLOSURE_PTR,pos); + } else { + SET_GEN_MARKED_PTRS(MStack,ptrs,0L); + POP_MSTACK("DYN ",DYN_CLOSURE_PTR,ptrs); + } + FUNEND; +} +\end{code} + + +The start code for \tr{TUPLE} (all-pointer) objects. There can be no +such object without any pointers, so we don't check for this case. + +\begin{code} +STGFUN(_PRStart_Tuple) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("TUPL", TUPLE_CLOSURE_NoPTRS(Mark)); + INIT_MSTACK(TUPLE_CLOSURE_PTR); + } + FUNEND; +} +\end{code} + +Now the ``in'' case. + +\begin{code} +STGFUN(_PRIn_I_Tuple) +{ + W_ ptrs; + BitWord pos; + + FUNBEGIN; + ptrs = TUPLE_CLOSURE_NoPTRS(MStack); + GET_GEN_MARKED_PTRS(pos,MStack,ptrs); + + if (++pos < ptrs) { + SET_GEN_MARKED_PTRS(MStack,ptrs,pos); + CONTINUE_MARKING_NODE("TUPL",pos); + MOVE_TO_NEXT_PTR(TUPLE_CLOSURE_PTR,pos); + } else { + SET_GEN_MARKED_PTRS(MStack,ptrs,0L); + POP_MSTACK("TUPL",TUPLE_CLOSURE_PTR,ptrs); + } + FUNEND; +} +\end{code} + + +\begin{code} +/*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/ +/* Only if special GC treatment required */ + +#ifdef GC_MUT_REQUIRED + +STGFUN(_PRStart_MuTuple) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("MUT ", MUTUPLE_CLOSURE_NoPTRS(Mark)); + INIT_MSTACK(MUTUPLE_CLOSURE_PTR); + } + FUNEND; +} + +STGFUN(_PRIn_I_MuTuple) +{ + W_ ptrs; + BitWord pos; + + FUNBEGIN; + ptrs = MUTUPLE_CLOSURE_NoPTRS(MStack); + GET_GEN_MARKED_PTRS(pos,MStack,ptrs); + + if (++pos < ptrs) { + SET_GEN_MARKED_PTRS(MStack,ptrs,pos); + CONTINUE_MARKING_NODE("MUT",pos); + MOVE_TO_NEXT_PTR(MUTUPLE_CLOSURE_PTR,pos); + } else { + SET_GEN_MARKED_PTRS(MStack,ptrs,0L); + POP_MSTACK("MUT ",MUTUPLE_CLOSURE_PTR,ptrs); + } + FUNEND; +} + +#endif /* GCap || GCgn */ +\end{code} + +There are no pointers in a \tr{DATA} closure, so just mark the +closure and return. + +\begin{code} +STGFUN(_PRStart_Data) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + } else + INIT_MARK_NODE("DATA", 0); + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + +%**************************************************************************** +% +\subsubsection[mark-specials]{Special cases} +% +%**************************************************************************** + +Black hole closures simply mark themselves and return. + +\begin{code} +STGFUN(_PRStart_BH) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + } else + INIT_MARK_NODE("BH ", 0); + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + +Marking a Static Closure -- Just return as if Marked + +\begin{code} +STGFUN(_PRStart_Static) +{ + FUNBEGIN; + DEBUG_PR_STAT; + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + +Marking an Indirection -- Set Mark to ind addr and mark this. +Updating of reference when we return will short indirection. + +\begin{code} +STGFUN(_PRStart_Ind) +{ + FUNBEGIN; + DEBUG_PR_IND; + Mark = (P_) IND_CLOSURE_PTR(Mark); + JUMP_MARK; + FUNEND; +} +\end{code} + +``Permanent indirection''---used in profiling. Works basically +like @_PRStart_1@ (one pointer). +\begin{code} +#if defined(USE_COST_CENTRES) +STGFUN(_PRStart_PI) +{ + FUNBEGIN; +/* This test would be here if it really was like a PRStart_1. + But maybe it is not needed because a PI cannot have two + things pointing at it (so no need to mark it), because + they are only created in exactly one place in UpdatePAP. + ??? WDP 95/07 + + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { +*/ + INIT_MARK_NODE("PI ",1); + /* the "1" above is dodgy (i.e. wrong), but it is never + used except in debugging info. ToDo??? WDP 95/07 + */ + INIT_MSTACK(PERM_IND_CLOSURE_PTR); +/* } */ + FUNEND; +} +STGFUN(_PRIn_PI) +{ + FUNBEGIN; + POP_MSTACK("PI ",PERM_IND_CLOSURE_PTR,1); + /* the "1" above is dodgy (i.e. wrong), but it is never + used except in debugging info. ToDo??? WDP 95/07 + */ + FUNEND; +} +#endif +\end{code} + +Marking a ``selector closure'': This is a size-2 SPEC thunk that +selects word $n$; if the thunk's pointee is evaluated, then we short +out the selection, {\em just like an indirection}. If it is still +unevaluated, then we behave {\em exactly as for a SPEC-2 thunk}. + +{\em Should we select ``on the way down'' (in \tr{_PRStart_Selector}) +or ``on the way back up'' (\tr{_PRIn_Selector})?} Answer: probably on +the way down. Downside: we are flummoxed by indirections, so we'll +have to wait until the {\em next} major GC to do the selections (after +the indirections are sorted out in this GC). But the downside of +doing selections on the way back up is that we are then in a world of +reversed pointers, and selecting a reversed pointer---we've see this +on selectors for very recursive structures---is a total disaster. +(WDP 94/12) + +\begin{code} +#if defined(_GC_DEBUG) +#define IF_GC_DEBUG(x) x +#else +#define IF_GC_DEBUG(x) /*nothing*/ +#endif + +/* _PRStartSelector_<n> is a (very) glorified _PRStart_1 */ + +#if 0 +/* testing */ +#define MARK_SELECTOR(n) \ +STGFUN(CAT2(_PRStartSelector_,n)) \ +{ \ + P_ maybe_con; \ + FUNBEGIN; \ + \ + /* must be a SPEC 2 1 closure */ \ + ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2); \ + ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1); \ + ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */ \ + \ + JMP_(_PRStart_1); \ + \ + FUNEND; \ +} +#endif /* 0 */ + +#define MARK_SELECTOR(n) \ +STGFUN(CAT2(_PRStartSelector_,n)) \ +{ \ + P_ maybe_con; \ + FUNBEGIN; \ + \ + /* must be a SPEC 2 1 closure */ \ + ASSERT(INFO_SIZE(INFO_PTR(Mark)) == 2); \ + ASSERT(INFO_NoPTRS(INFO_PTR(Mark)) == 1); \ + ASSERT(MIN_UPD_SIZE == 2); /* otherwise you are hosed */ \ + \ + if (IS_MARK_BIT_SET(Mark)) { /* already marked */ \ + DEBUG_PR_MARKED; \ + JUMP_MARK_RETURN; \ + } \ + \ + maybe_con = (P_) *(Mark + _FHS); \ + \ + IF_GC_DEBUG( \ + if (SM_trace & 2) { \ + fprintf(stderr, "Start Selector %d: 0x%lx, info 0x%lx, size %ld, ptrs %ld, maybe_con 0x%lx, marked? 0x%%lx, info 0x%lx", \ + (n), Mark, INFO_PTR(Mark), INFO_SIZE(INFO_PTR(Mark)), \ + INFO_NoPTRS(INFO_PTR(Mark)), \ + maybe_con, /*danger:IS_MARK_BIT_SET(maybe_con),*/ \ + INFO_PTR(maybe_con)); \ + fprintf(stderr, ", tag %ld, size %ld, ptrs %ld", \ + INFO_TAG(INFO_PTR(maybe_con)), \ + INFO_SIZE(INFO_PTR(maybe_con)), \ + INFO_NoPTRS(INFO_PTR(maybe_con))); \ + if (INFO_TAG(INFO_PTR(maybe_con)) >=0) { \ + /* int i; */ \ + /* for (i = 0; i < INFO_SIZE(INFO_PTR(maybe_con)); i++) { */ \ + /* fprintf(stderr, ", 0x%lx", maybe_con[_FHS + i]); */ \ + /*}*/ \ + fprintf(stderr, "=> 0x%lx", maybe_con[_FHS + (n)]); \ + } \ + fprintf(stderr, "\n"); \ + } ) \ + \ + if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */\ + || IS_MARK_BIT_SET(maybe_con) /* been here: may be mangled */ \ + || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */ \ + /* see below for OLD test we used here (WDP 95/04) */ \ + /* ToDo: decide WHNFness another way? */ \ + JMP_(_PRStart_1); \ + \ + /* some things should be true about the pointee */ \ + ASSERT(INFO_TAG(INFO_PTR(maybe_con)) == 0); \ + /* ASSERT((n) < INFO_SIZE(INFO_PTR(maybe_con))); not true if static */ \ + \ + /* OK, it is evaluated: behave just like an indirection */ \ + \ + Mark = (P_) (maybe_con[_FHS + (n)]); \ + /* Mark now has the result of the selection */ \ + JUMP_MARK; \ + \ + FUNEND; \ +} + +#if 0 +/* OLD test: + the IS_STATIC test was to protect the IS_MARK_BIT_SET check; + but the IS_MARK_BIT_SET test was only there to avoid + mangled pointers, but we cannot have mangled pointers anymore + (after RTBLs came our way). + SUMMARY: we toss both of the "guard" tests. + */ + if (IS_STATIC(INFO_PTR(maybe_con)) /* static: cannot chk mark bit */ + || IS_MARK_BIT_SET(maybe_con) /* been here: may be mangled */ + || INFO_TAG(INFO_PTR(maybe_con)) < 0) /* not in WHNF */ +#endif /* 0 */ + +MARK_SELECTOR(0) +MARK_SELECTOR(1) +MARK_SELECTOR(2) +MARK_SELECTOR(3) +MARK_SELECTOR(4) +MARK_SELECTOR(5) +MARK_SELECTOR(6) +MARK_SELECTOR(7) +MARK_SELECTOR(8) +MARK_SELECTOR(9) +MARK_SELECTOR(10) +MARK_SELECTOR(11) +MARK_SELECTOR(12) + +#undef IF_GC_DEBUG /* get rid of it */ +\end{code} + +Marking a Constant Closure -- Set Mark to corresponding static +closure. Updating of reference will redirect reference to the static +closure. + +\begin{code} +STGFUN(_PRStart_Const) +{ + FUNBEGIN; + DEBUG_PR_CONST; + Mark = (P_) CONST_STATIC_CLOSURE(INFO_PTR(Mark)); + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + +Marking a CharLike Closure -- Set Mark to corresponding static +closure. Updating of reference will redirect reference to the static +closure. + +\begin{code} +STGFUN(_PRStart_CharLike) +{ + FUNBEGIN; + DEBUG_PR_CHARLIKE; + Mark = (P_) CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark)); + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + +Marking an IntLike Closure -- Set Mark to corresponding static closure +if in range. Updating of reference to this will redirect reference to +the static closure. + +\begin{code} +STGFUN(_PRStart_IntLike) +{ + I_ val; + + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + } else { + val = INTLIKE_VALUE(Mark); + + if ((val <= MAX_INTLIKE) && (val >= MIN_INTLIKE)) { + DEBUG_PR_INTLIKE_TO_STATIC; + INFO_PTR(Mark) = (W_) Ind_info; + IND_CLOSURE_PTR(Mark) = (W_) INTLIKE_CLOSURE(val); + Mark = (P_) IND_CLOSURE_PTR(Mark); + } else { + /* out of range of static closures */ + DEBUG_PR_INTLIKE_IN_HEAP; + INIT_MARK_NODE("INT ",0); + } + } + JUMP_MARK_RETURN; + FUNEND; +} +\end{code} + +CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD! + +\begin{code} +#if defined(GCgn) + +/* Marking an OldGen root -- treat as indirection if it references the old generation */ + +STGFUN(_PRStart_OldRoot) +{ + P_ oldroot; + + FUNBEGIN; + oldroot = (P_) IND_CLOSURE_PTR(Mark); + + if (oldroot <= HeapLim) /* does the root reference the old generation ? */ + { + DEBUG_PR_OLDIND; + Mark = oldroot; /* short circut if the old generation root */ + JUMP_MARK; /* references an old generation closure */ + } + + else + { + INIT_MARK_NODE("OldRoot",1); /* oldroot to new generation */ + INIT_MSTACK(SPEC_CLOSURE_PTR); /* treat as _PRStart_1 */ + } + FUNEND; +} + +#endif /* GCgn */ + +\end{code} + +Special error routine, used for closures which should never call their +``in'' code. + +\begin{code} +STGFUN(_PRIn_Error) +{ + FUNBEGIN; + fprintf(stderr,"Called _PRIn_Error\nShould never occur!\n"); + abort(); + FUNEND; +} +\end{code} + +%**************************************************************************** +% +\subsubsection[mark-fetchme]{Marking FetchMe Objects (parallel only)} +% +%**************************************************************************** + +\begin{code} +#ifdef PAR +\end{code} + +FetchMe's present a unique problem during global GC. Since the IMU short-circuits +indirections during its evacuation, it may return a PLC as the new global address +for a @FetchMe@ node. This has the effect of turning the @FetchMe@ into an +indirection during local garbage collection. Of course, we'd like to short-circuit +this indirection immediately. + +\begin{code} +STGFUN(_PRStart_FetchMe) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + } else + INIT_MARK_NODE("FME ", 0); + + JUMP_MARK_RETURN; + FUNEND; +} + +STGFUN(_PRStart_BF) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("BF ", BF_CLOSURE_NoPTRS(dummy)); + INIT_MSTACK(BF_CLOSURE_PTR); + } + FUNEND; +} + +STGFUN(_PRIn_BF) +{ + BitWord mbw; + + FUNBEGIN; + GET_MARKED_PTRS(mbw, MStack, BF_CLOSURE_NoPTRS(dummy)); + if (++mbw < BF_CLOSURE_NoPTRS(dummy)) { + SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), mbw); + CONTINUE_MARKING_NODE("BF ", mbw); + MOVE_TO_NEXT_PTR(BF_CLOSURE_PTR, mbw); + } else { + SET_MARKED_PTRS(MStack, BF_CLOSURE_NoPTRS(dummy), 0L); + POP_MSTACK("BF ", BF_CLOSURE_PTR, BF_CLOSURE_NoPTRS(dummy)); + } + FUNEND; +} + +#endif /* PAR */ +\end{code} + +%**************************************************************************** +% +\subsubsection[mark-tso]{Marking Thread State Objects (threaded only)} +% +%**************************************************************************** + +First mark the link, then mark all live registers (StkO plus the VanillaRegs +indicated by Liveness). + +CHANGE THIS FOR THE @COMMON_ITBLS@ WORLD! + +\begin{code} + +#ifdef CONCURRENT + +STGFUN(_PRStart_BQ) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("BQ ", BQ_CLOSURE_NoPTRS(Mark)); + INIT_MSTACK(BQ_CLOSURE_PTR); + } + FUNEND; +} + +STGFUN(_PRIn_BQ) +{ + FUNBEGIN; + POP_MSTACK("BQ ",BQ_CLOSURE_PTR,1); + FUNEND; +} + +STGFUN(_PRStart_TSO) +{ + P_ temp; + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("TSO ", 0); + temp = TSO_LINK(Mark); + TSO_LINK(Mark) = MStack; + MStack = Mark; + Mark = temp; + JUMP_MARK; + } + FUNEND; +} +\end{code} + +When we're in the TSO, pos 0 is the link, 1 is the StkO, and 2-10 correspond to +the vanilla registers r[pos-2]. + +\begin{code} +STGFUN(_PRIn_TSO) +{ + W_ liveness; + BitWord oldpos, newpos; + STGRegisterTable *r; + P_ temp, mstack; + + FUNBEGIN; + GET_MARKED_PTRS(oldpos,MStack,TSO_PTRS); + r = TSO_INTERNAL_PTR(MStack); + + switch(oldpos) { + case 0: + /* Just did the link; now do the StkO */ + SET_MARKED_PTRS(MStack,TSO_PTRS,1L); + temp = r->rStkO; + r->rStkO = TSO_LINK(MStack); + TSO_LINK(MStack) = Mark; + Mark = temp; + DEBUG_PRIN("TSO ", 1); + JUMP_MARK; + break; + case 1: + /* Just did the StkO; just update it, saving the old mstack */ + mstack = r->rStkO; + r->rStkO = Mark; + break; + default: + /* update the register we just did; save the old mstack */ + mstack = r->rR[oldpos - 2].p; + r->rR[oldpos - 2] = Mark; + break; + } + + /* liveness of the remaining registers */ + liveness = r->rLiveness >> (oldpos - 1); + + if (liveness == 0) { + /* Restore MStack and return */ + SET_MARKED_PTRS(MStack,TSO_PTRS,0L); + DEBUG_PRLAST("TSO ", oldpos); + Mark = MStack; + MStack = mstack; + JUMP_MARK_RETURN; + } + + /* More to do in this TSO */ + + /* Shift past non-ptr registers */ + for(newpos = oldpos + 1; (liveness & 1) == 0; liveness >>= 1) { + newpos++; + } + + /* Mark the next one */ + SET_MARKED_PTRS(MStack,TSO_PTRS,newpos); + Mark = r->rR[newpos - 2].p; + r->rR[newpos - 2].p = mstack; + DEBUG_PRIN("TSO ", oldpos); + JUMP_MARK; + + FUNEND; +} + +\end{code} + +%**************************************************************************** +% +\subsubsection[mark-stko]{Marking Stack Objects (threaded only)} +% +%**************************************************************************** + +First mark the A stack, then mark all updatees in the B stack. + +\begin{code} + +STGFUN(_PRStart_StkO) +{ + P_ temp; + I_ size; + I_ cts_size; + + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("STKO", 0); + size = STKO_CLOSURE_SIZE(Mark); + cts_size = STKO_CLOSURE_CTS_SIZE(Mark); + SET_GEN_MARKED_PTRS(Mark,size,(BitWord)(cts_size + 1)); + temp = STKO_LINK(Mark); + STKO_LINK(Mark) = MStack; + MStack = Mark; + Mark = temp; + JUMP_MARK; + } + FUNEND; +} +\end{code} + +Now the ``in'' code for \tr{STKO} closures. First the A stack is flushed, +then we chain down the update frames in the B stack, marking the update +nodes. When all have been marked we pop the stack and return. + +\begin{code} +STGFUN(_PRIn_StkO) +{ + BitWord oldpos, newpos; + P_ mstack; + I_ size; + + FUNBEGIN; + + size = STKO_CLOSURE_SIZE(MStack); + GET_GEN_MARKED_PTRS(oldpos, MStack, size); + + if (oldpos > STKO_CLOSURE_CTS_SIZE(MStack)) { + /* Update the link, saving the old mstack */ + mstack = STKO_LINK(MStack); + STKO_LINK(MStack) = Mark; + } else { + /* Update the pointer, saving the old mstack */ + mstack = (P_) STKO_CLOSURE_PTR(MStack, oldpos); + STKO_CLOSURE_PTR(MStack, oldpos) = (W_) Mark; + } + + /* Calculate the next position to mark */ + if (oldpos > STKO_SpA_OFFSET(MStack)) { + /* Just walk backwards down the A stack */ + newpos = oldpos - 1; + SET_GEN_MARKED_PTRS(MStack,size,newpos); + Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos); + STKO_CLOSURE_PTR(MStack, newpos) = (W_) mstack; + DEBUG_PRIN("STKA", oldpos); + JUMP_MARK; + } else if (oldpos <= STKO_SuB_OFFSET(MStack)) { + /* We're looking at an updatee in the B stack; find the next SuB up the chain */ + P_ subptr; + + subptr = GRAB_SuB(STKO_CLOSURE_ADDR(MStack, oldpos - BREL(UF_UPDATEE))); + newpos = STKO_CLOSURE_OFFSET(MStack,subptr); + } else { + /* Just fell off the end of the A stack; grab the first SuB */ + newpos = STKO_SuB_OFFSET(MStack); + } + + if (newpos == 0) { /* Grrr... newpos is 1-based */ + /* Restore MStack and return */ + SET_GEN_MARKED_PTRS(MStack,size,0L); + DEBUG_PRLAST("STKO", oldpos); + Mark = MStack; + MStack = mstack; + JUMP_MARK_RETURN; + } + + /* newpos is actually the SuB; we want the corresponding updatee */ + SET_GEN_MARKED_PTRS(MStack,size,newpos + BREL(UF_UPDATEE)); + Mark = (P_) STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)); + STKO_CLOSURE_PTR(MStack, newpos + BREL(UF_UPDATEE)) = (W_) mstack; + DEBUG_PRIN("STKB", oldpos); + JUMP_MARK; + + FUNEND; +} +#endif /* CONCURRENT */ +\end{code} + +%**************************************************************************** +% +\subsubsection[mark-caf]{Marking CAFs} +% +%**************************************************************************** + +A CAF is shorted out as if it is an indirection. +The CAF reference is explicitly updated by the garbage collector. + +\begin{code} +STGFUN(_PRStart_Caf) +{ + FUNBEGIN; + DEBUG_PR_CAF; + Mark = (P_) IND_CLOSURE_PTR(Mark); + JUMP_MARK; + FUNEND; +} + +#if 0 /* Code to avoid explicit updating of CAF references */ + /* We need auxiliary mark and update reference info table */ + +CAF_MARK_UPD_ITBL(Caf_Mark_Upd_info,const); + +/* Start marking a CAF -- special mark upd info table */ +/* Change to marking state and mark reference */ + +STGFUN(_PRStart_Caf) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKED; + JUMP_MARK_RETURN; + } else { + INIT_MARK_NODE("CAF ",1); + INIT_MSTACK(IND_CLOSURE_PTR2); + } + FUNEND; +} + +/* Completed marking a CAF -- special mark upd info table */ +/* Change info table back to normal CAF info, return reference (Mark) */ + +STGFUN(_PRInLast_Caf) +{ + P_ temp; + + FUNBEGIN; + DEBUG_PRLAST_CAF; + SET_INFO_PTR(MStack, Caf_info); /* normal marked CAF */ + + /* Like POP_MSTACK */ + temp = MStack; + MStack = (P_) IND_CLOSURE_PTR(temp); + IND_CLOSURE_PTR(temp) = (W_) Mark; + + /* Mark left unmodified so CAF reference is returned */ + JUMP_MARK_RETURN; + FUNEND; +} + +/* Marking a CAF currently being marked -- special mark upd info table */ +/* Just return CAF as if marked -- wont be shorted out */ +/* Marking once reference marked and updated -- normal CAF info table */ +/* Return reference to short CAF out */ + +STGFUN(_PRStart_Caf) +{ + FUNBEGIN; + if (IS_MARK_BIT_SET(Mark)) { + DEBUG_PR_MARKING_CAF; + JUMP_MARK_RETURN; + } else { + DEBUG_PR_MARKED_CAF; + Mark = (P_) IND_CLOSURE_PTR(Mark); + JUMP_MARK_RETURN; + } + FUNEND; +} + +#define DEBUG_PR_MARKED_CAF \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark CAF (Marked): 0x%lx -> 0x%lx, info 0x%lx\n", \ + Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark)) + +#define DEBUG_PR_MARKING_CAF \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark CAF (Marking): 0x%lx -> 0x%lx, info 0x%lx\n", \ + Mark, Mark, INFO_PTR(Mark)) + +#define DEBUG_PRLAST_CAF \ + if (SM_trace & 8) \ + fprintf(stderr, "PRRet Last (CAF ): 0x%lx -> 0x%lx, info 0x%lx -> 0x%lx ptrs 1\n", \ + MStack, Mark, INFO_PTR(MStack), Caf_info) + +#endif /* 0 */ + +\end{code} + +%**************************************************************************** +% +\subsection[mark-root]{Root Marking Code} +% +%**************************************************************************** + +Used by \tr{SMmarking.lc} -- but needs to be in \tr{.lhc} file. + +These are routines placed in closures at the bottom of the marking stack + +\begin{code} +STGFUN(_Dummy_PRReturn_entry) +{ + FUNBEGIN; + fprintf(stderr,"Called _Dummy_PRReturn_entry\nShould never occur!\n"); + abort(); + return(0); /* won't happen; quiets compiler warnings */ + FUNEND; +} + +EXTFUN(_PRMarking_MarkNextRoot); +EXTFUN(_PRMarking_MarkNextCAF); + +#ifdef CONCURRENT +EXTFUN(_PRMarking_MarkNextSpark); +#endif + +#ifdef PAR +EXTFUN(_PRMarking_MarkNextGA); +#else +EXTFUN(_PRMarking_MarkNextAStack); +EXTFUN(_PRMarking_MarkNextBStack); +#endif /* not parallel */ + +CAT_DECLARE(Dummy_PrReturn,INTERNAL_KIND,"DUMMY_PRRETURN","DUMMY_PRRETURN") + /* just one, shared */ + +DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextRoot_closure, + _PRMarking_MarkNextRoot_info, + _PRMarking_MarkNextRoot, + _Dummy_PRReturn_entry); + +#ifdef CONCURRENT +DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextSpark_closure, + _PRMarking_MarkNextSpark_info, + _PRMarking_MarkNextSpark, + _Dummy_PRReturn_entry); +#endif + +#ifdef PAR +DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextGA_closure, + _PRMarking_MarkNextGA_info, + _PRMarking_MarkNextGA, + _Dummy_PRReturn_entry); +#else +DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextAStack_closure, + _PRMarking_MarkNextAStack_info, + _PRMarking_MarkNextAStack, + _Dummy_PRReturn_entry); + +DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextBStack_closure, + _PRMarking_MarkNextBStack_info, + _PRMarking_MarkNextBStack, + _Dummy_PRReturn_entry); + +#endif /* PAR */ + +DUMMY_PRRETURN_CLOSURE(_PRMarking_MarkNextCAF_closure, + _PRMarking_MarkNextCAF_info, + _PRMarking_MarkNextCAF, + _Dummy_PRReturn_entry); + +STGFUN(_PRMarking_MarkNextRoot) +{ + extern P_ sm_roots_end; /* &roots[rootno] -- one beyond the end */ + + FUNBEGIN; + /* Update root -- may have short circuited Ind */ + *MRoot = (W_) Mark; + + /* Is the next off the end */ + if (++MRoot >= sm_roots_end) + RESUME_(miniInterpretEnd); + + Mark = (P_) *MRoot; + JUMP_MARK; + FUNEND; +} + +#ifdef CONCURRENT +STGFUN(_PRMarking_MarkNextSpark) +{ + extern P_ sm_roots_end; /* PendingSparksTl[pool] */ + + FUNBEGIN; + /* Update root -- may have short circuited Ind */ + *MRoot = (W_) Mark; + + /* Is the next off the end */ + if (++MRoot >= sm_roots_end) + RESUME_(miniInterpretEnd); + + Mark = (P_) *MRoot; + JUMP_MARK; + FUNEND; +} +#endif + +#ifdef PAR +STGFUN(_PRMarking_MarkNextGA) +{ + FUNBEGIN; + /* Update root -- may have short circuited Ind */ + ((GALA *)MRoot)->la = Mark; + + do { + MRoot = (P_) ((GALA *) MRoot)->next; + } while (MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT); + + /* Is the next off the end */ + if (MRoot == NULL) + RESUME_(miniInterpretEnd); + + Mark = ((GALA *)MRoot)->la; + JUMP_MARK; + FUNEND; +} + +#else + +STGFUN(_PRMarking_MarkNextAStack) +{ + FUNBEGIN; + /* Update root -- may have short circuited Ind */ + *MRoot = (W_) Mark; + + /* Is the next off the end */ + if (SUBTRACT_A_STK( (PP_) ++MRoot, stackInfo.botA) < 0) + RESUME_(miniInterpretEnd); + + Mark = (P_) *MRoot; + JUMP_MARK; + FUNEND; +} + + +STGFUN(_PRMarking_MarkNextBStack) +{ + FUNBEGIN; + /* Update root -- may have short circuited Ind */ + PUSH_UPDATEE(MRoot, Mark); + + MRoot = GRAB_SuB(MRoot); + + /* Is the next off the end */ + if (SUBTRACT_B_STK(MRoot, stackInfo.botB) < 0) + RESUME_(miniInterpretEnd); + + Mark = GRAB_UPDATEE(MRoot); + JUMP_MARK; + FUNEND; +} +#endif /* PAR */ +\end{code} + +Mark the next CAF in the CAF list. + +\begin{code} +STGFUN(_PRMarking_MarkNextCAF) +{ + FUNBEGIN; + /* Update root -- may have short circuted Ind */ + IND_CLOSURE_PTR(MRoot) = (W_) Mark; + + MRoot = (P_) IND_CLOSURE_LINK(MRoot); + + /* Is the next CAF the end of the list */ + if (MRoot == 0) + RESUME_(miniInterpretEnd); + + Mark = (P_) IND_CLOSURE_PTR(MRoot); + JUMP_MARK; + FUNEND; +} +\end{code} + +\begin{code} +#if 0 /* Code to avoid explicit updating of CAF references */ + +STGFUN(_PRMarking_MarkNextCAF) +{ + FUNBEGIN; + MRoot = (P_) IND_CLOSURE_LINK(MRoot); + + /* Is the next CAF the end of the list */ + if (MRoot == 0) + RESUME_(miniInterpretEnd); + + Mark = MRoot; + JUMP_MARK; + FUNEND; +} +#endif /* 0 */ +\end{code} + +Multi-slurp protection. + +\begin{code} +#endif /* _INFO_MARKING */ +\end{code} diff --git a/ghc/runtime/storage/SMmarkDefs.lh b/ghc/runtime/storage/SMmarkDefs.lh new file mode 100644 index 0000000000..fccce1aaa2 --- /dev/null +++ b/ghc/runtime/storage/SMmarkDefs.lh @@ -0,0 +1,322 @@ +%**************************************************************************** +% +\section[SMmarkDefs.lh]{Definitions used by Pointer-Reversing Mark code} +% +% (c) P. Sansom, K. Hammond, Glasgow University, January 26th 1993. +% +%**************************************************************************** + +Describe how to set the mark bit for a closure. + +\begin{code} +#if defined(GCgn) + +#define SET_MARK_BIT(closure) \ + do { \ + if (closure <= HeapLim) /* tested heap range for GCgn */ \ + { \ + long _hp_word = ((P_)closure) - HeapBase; \ + ASSERT(!IS_STATIC(INFO_PTR(closure))); \ + DEBUG_SET_MARK(closure, _hp_word); \ + BitArray[_hp_word / BITS_IN(BitWord)] |= \ + 1L << (_hp_word & (BITS_IN(BitWord) - 1)); \ + } \ + } while(0) + +#define CLEAR_MARK_BIT(closure) \ + do { \ + long _hp_word = ((P_)closure) - HeapBase; \ + ASSERT(!IS_STATIC(INFO_PTR(closure))); \ + BitArray[_hp_word / BITS_IN(BitWord)] &= \ + ~(1L << (_hp_word & (BITS_IN(BitWord) - 1))); \ + } while (0) + +#else + +#define SET_MARK_BIT(closure) \ + do { \ + long _hp_word = ((P_)closure) - HeapBase; \ + ASSERT(!IS_STATIC(INFO_PTR(closure))); \ + DEBUG_SET_MARK(closure, _hp_word); \ + BitArray[_hp_word / BITS_IN(BitWord)] |= \ + 1L << (_hp_word & (BITS_IN(BitWord) - 1)); \ + } while (0) + +#define CLEAR_MARK_BIT(closure) \ + do { \ + long _hp_word = ((P_)closure) - HeapBase; \ + ASSERT(!IS_STATIC(INFO_PTR(closure))); \ + BitArray[_hp_word / BITS_IN(BitWord)] &= \ + ~(1L << (_hp_word & (BITS_IN(BitWord) - 1))); \ + } while (0) + +\end{code} + +Macros from hell for frobbing bits in the bit array while marking. We +maintain a counter after the mark bit that tells us which pointers +we've visited in a closure. The bits in this counter may span word +boundaries, and require some considerable ickiness to get munged into +one word so Mr C Programmer can use them. + +Three variants follow. The first is for closures which contain fewer +pointers than there are bits in a word. + +\begin{code} + +#define GM_MASK(x) ((1L << (x)) - 1) + +#define GET_MARKED_PTRS(dest,closure,ptrs) \ + do { \ + long hw = ((P_)(closure)) - HeapBase + 1; \ + BitWord *bw = BitArray + (hw / BITS_IN(BitWord)); \ + int offset = hw & (BITS_IN(BitWord) - 1); \ + int bat = BITS_IN(BitWord) - offset; \ + \ + ASSERT(!IS_STATIC(INFO_PTR(closure))); \ + \ + (dest) = (ptrs) <= bat ? \ + bw[0] >> offset & GM_MASK(ptrs) : \ + bw[0] >> offset | \ + (bw[1] & GM_MASK((ptrs) - bat)) << bat; \ + } while (0) + +/* hw is the offset in words of closure from HeapBase + 1. + + bw points to the BitArray word containing the bit corresponding + to the *second* word of the closure [hence +1 above] + (the bit corresp first word is the mark bit) + + offset is the offset (in bits, from LS end, zero indexed) within *bw + of the first bit of value in *bw, + + bat is offset from the other end of the word; that's the same + as the number of bits available to store value in *bw. + + +NOTA BENE: this code is awfully conservative. In order to store a +value which ranges 0--ptrs we use a field of ptrs bits wide. We +only need a field of log(ptrs) wide! + +*/ + +/* "ptrs" is actually used as the width of the bit-field + in which we store "val". */ + +#define SET_MARKED_PTRS(closure,ptrs,val) \ + do { \ + long hw = ((P_)(closure)) - HeapBase + 1; \ + BitWord *bw = BitArray + (hw / BITS_IN(BitWord)); \ + int offset = hw & (BITS_IN(BitWord) - 1); \ + int bat = BITS_IN(BitWord) - offset; \ + BitWord bits; \ + \ + ASSERT( (ptrs) < BITS_IN(BitWord) ); \ + ASSERT(!IS_STATIC(INFO_PTR(closure))); \ + \ + bits = bw[0] & ~(GM_MASK(ptrs) << offset); \ + bw[0] = bits | (val) << offset; \ + if ((ptrs) > bat) { \ + bits = bw[1] & ~GM_MASK((ptrs) - bat); \ + bw[1] = bits | ((val) >> bat); \ + } \ + } while (0) +/* NB Since ptrs < BITS_IN(BitWord) + we can be sure that the conditional will only happen if bat is strictly + *smaller* than BITS_IN(BitWord), and hence the right shift in the + last line is ok */ + +/* + * These are for the GEN family, which may blow up the GM_MASK macro. + */ + + /* If there are more ptrs than bits in a word, we still + use just one word to store the value; value is bound to + be < 2**(bits-in-word - 1) */ + +#define __MIN__(a,b) (((a) < (b)) ? (a) : (b)) + +#define GET_GEN_MARKED_PTRS(dest,closure,ptrs) \ + GET_MARKED_PTRS(dest,closure,__MIN__(ptrs,BITS_IN(BitWord)-1)) + +#define SET_GEN_MARKED_PTRS(closure,ptrs,val) \ + SET_MARKED_PTRS(closure,__MIN__(ptrs,BITS_IN(BitWord)-1),val) + +/* Be very careful to use the following macro only for dynamic closures! */ + +#define IS_MARK_BIT_SET(closure) \ + ((BitArray[(((P_)closure) - HeapBase) / BITS_IN(BitWord)] >> \ + ((((P_)closure) - HeapBase) & (BITS_IN(BitWord) - 1))) & 0x1) + +#endif +\end{code} + +Don't set the mark bit when changing to marking in the next pointer. + +\begin{code} +#define INIT_MARK_NODE(dbg,ptrs) \ + do { \ + DEBUG_PRSTART(dbg, ptrs); \ + LINK_GLOBALADDRESS(Mark); \ + SET_MARK_BIT(Mark); \ + } while (0) + +#define CONTINUE_MARKING_NODE(dbg,pos) \ + do { \ + DEBUG_PRIN(dbg, pos); \ + } while (0) +\end{code} + +@JUMP_MARK@ and @JUMP_MARK_RETURN@ define how to jump to the marking +entry code for a child closure (\tr{Mark}), or to the return code for +its parent (\tr{MStack}), when marking's been completed. + +\begin{code} +#define JUMP_MARK \ + JMP_(PRMARK_CODE(INFO_PTR(Mark))) + +#define JUMP_MARK_RETURN \ + JMP_(PRRETURN_CODE(INFO_PTR(MStack))) +\end{code} + +Initialise the marking stack to mark from the first pointer in the +closure (as specified by \tr{first_ptr}). The type of the closure is +given by \tr{closure_ptr}. + +\begin{code} +#define INIT_MSTACK_FROM(closure_ptr,first_ptr) \ + do { \ + P_ temp = (P_) closure_ptr(Mark, first_ptr); \ + closure_ptr(Mark, first_ptr) = (W_) MStack; \ +/*fprintf(stderr,"first_ptr=%d;temp=%lx;Mark=%lx;MStack=%lx\n",first_ptr,temp,Mark,MStack);*/ \ + MStack = Mark; \ + Mark = temp; \ + JUMP_MARK; \ + } while (0) +\end{code} + +Initialise the marking stack to mark from the first pointer in +the closure. The type of the closure is given by \tr{closure_ptr}. + +\begin{code} +#define INIT_MSTACK(closure_ptr) \ + INIT_MSTACK_FROM(closure_ptr,1) +\end{code} + +Move to the next pointer after \tr{pos} in the closure whose +type is given by \tr{closure_ptr}. + +\begin{code} +#define MOVE_TO_NEXT_PTR(closure_ptr,pos) \ + do { \ + P_ temp = (P_) closure_ptr(MStack, pos+1); \ + closure_ptr(MStack, pos+1) = closure_ptr(MStack, pos); \ + closure_ptr(MStack, pos) = (W_) Mark; \ + Mark = temp; \ + JUMP_MARK; \ + } while(0) +\end{code} + +Pop the mark stack at \tr{pos}, having flushed all pointers in +a closure. + +\begin{code} +#define POP_MSTACK(dbg,closure_ptr,pos) \ + do { \ + RESTORE_MSTACK(dbg,closure_ptr,pos); \ + JUMP_MARK_RETURN; \ + } while (0) + +#define RESTORE_MSTACK(dbg,closure_ptr,pos) \ + do { \ + P_ temp = Mark; \ + DEBUG_PRLAST(dbg, pos); \ + Mark = MStack; \ + MStack = (P_) closure_ptr(Mark, pos); \ + closure_ptr(Mark, pos) = (W_) temp; \ + } while (0) +\end{code} + +Define some debugging macros. + +\begin{code} +#if defined(_GC_DEBUG) + +#define DEBUG_PRSTART(type, ptrsvar) \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark Start (%s): 0x%lx, info 0x%lx ptrs %ld\n", \ + type, Mark, INFO_PTR(Mark), ptrsvar) + +#define DEBUG_PRIN(type, posvar) \ + if (SM_trace & 8) \ + fprintf(stderr, "PRRet In (%s): 0x%lx, info 0x%lx pos %ld\n", \ + type, MStack, INFO_PTR(MStack), posvar) + +#define DEBUG_PRLAST(type, ptrvar) \ + if (SM_trace & 8) \ + fprintf(stderr, "PRRet Last (%s): 0x%lx, info 0x%lx ptrs %ld\n", \ + type, MStack, INFO_PTR(MStack), ptrvar) + +#define DEBUG_PR_MARKED \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark Marked : 0x%lx, info 0x%lx\n", \ + Mark, INFO_PTR(Mark)) + +#define DEBUG_PR_STAT \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark Static : 0x%lx, info 0x%lx\n", \ + Mark, INFO_PTR(Mark)) + +#define DEBUG_PR_IND \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \ + Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark)) + +#define DEBUG_PR_CAF \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark Caf : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \ + Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark)) + +#define DEBUG_PR_CONST \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark Const : 0x%lx -> 0x%lx, info 0x%lx\n", \ + Mark, CONST_STATIC_CLOSURE(INFO_PTR(Mark)), INFO_PTR(Mark)) + +#define DEBUG_PR_CHARLIKE \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark CharLike (%lx) : 0x%lx -> 0x%lx, info 0x%lx\n", \ + CHARLIKE_VALUE(Mark), Mark, CHARLIKE_CLOSURE(CHARLIKE_VALUE(Mark)), INFO_PTR(Mark)) + +#define DEBUG_PR_INTLIKE_TO_STATIC \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark IntLike to Static (%ld) : 0x%lx -> 0x%lx, info 0x%lx\n", \ + INTLIKE_VALUE(Mark), Mark, INTLIKE_CLOSURE(INTLIKE_VALUE(Mark)), INFO_PTR(Mark)) + +#define DEBUG_PR_INTLIKE_IN_HEAP \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark IntLike in Heap (%ld) : 0x%lx, info 0x%lx\n", \ + INTLIKE_VALUE(Mark), Mark, INFO_PTR(Mark)) + +#define DEBUG_PR_OLDIND \ + if (SM_trace & 8) \ + fprintf(stderr, "PRMark OldRoot Ind : 0x%lx -> PRMark(0x%lx), info 0x%lx\n", \ + Mark, IND_CLOSURE_PTR(Mark), INFO_PTR(Mark)) + +#else + +#define DEBUG_PRSTART(type, ptrvar) +#define DEBUG_PRIN(type, posvar) +#define DEBUG_PRLAST(type, ptrvar) +#define DEBUG_PR_MARKED +#define DEBUG_PR_STAT +#define DEBUG_PR_IND +#define DEBUG_PR_CAF +#define DEBUG_PR_CONST +#define DEBUG_PR_CHARLIKE +#define DEBUG_PR_INTLIKE_TO_STATIC +#define DEBUG_PR_INTLIKE_IN_HEAP +#define DEBUG_PR_OLDIND + +#endif + +\end{code} + diff --git a/ghc/runtime/storage/SMmarking.lc b/ghc/runtime/storage/SMmarking.lc new file mode 100644 index 0000000000..33d366ea68 --- /dev/null +++ b/ghc/runtime/storage/SMmarking.lc @@ -0,0 +1,267 @@ +/************************************************************************* + MARKING OF ROOTS +*************************************************************************/ + +[Something needed here to explain what this is doing. KH] + +\begin{code} + +#define MARK_REG_MAP +#include "SMinternal.h" + +extern I_ doSanityChks; /* ToDo: move tidily */ + +#if defined(_INFO_MARKING) + +#if defined (__STG_GCC_REGS__) /* If we are using registers load _SAVE */ + +/* If we are using registers load _SAVE */ +#define Mark SAVE_Mark +#define MRoot SAVE_MRoot +#define MStack SAVE_MStack +#define BitArray SAVE_BitArray +#define HeapBase SAVE_HeapBase +#define HeapLim SAVE_HeapLim + +#endif /* registerized */ + +/* These in SMmark.lhc -- need to be in .hc file */ +EXTFUN(_startMarkWorld); + +EXTFUN(_PRMarking_MarkNextRoot); +EXTFUN(_PRMarking_MarkNextCAF); +EXTDATA(_PRMarking_MarkNextRoot_closure); +EXTDATA(_PRMarking_MarkNextCAF_closure); + +#ifdef CONCURRENT +EXTFUN(_PRMarking_MarkNextSpark); +EXTDATA(_PRMarking_MarkNextSpark_closure); +#endif + +#ifdef PAR +EXTFUN(_PRMarking_MarkNextGA); +EXTDATA(_PRMarking_MarkNextGA_closure); +#else +EXTFUN(_PRMarking_MarkNextAStack); +EXTFUN(_PRMarking_MarkNextBStack); +EXTDATA(_PRMarking_MarkNextAStack_closure); +EXTDATA(_PRMarking_MarkNextBStack_closure); +#endif /* not parallel */ + +P_ sm_roots_end; + +I_ +markHeapRoots(sm, cafs1, cafs2, base, lim, bit_array) + smInfo *sm; + P_ cafs1, cafs2; /* Pointer to CAF lists */ + P_ base; /* Heap closure in range only tested for by GCgn */ + P_ lim; + BitWord *bit_array; +{ +#ifdef CONCURRENT + int pool; +#endif + +#if 0 /* Code to avoid explicit updating of CAF references */ + + /* Before marking have to modify CAFs to auxillary info table */ + P_ CAFptr; + DEBUG_STRING("Setting Mark & Upd CAFs:"); + for (CAFptr = cafs1; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + INFO_PTR(CAFptr) = (W_) Caf_Mark_Upd_info; + } + for (CAFptr = cafs2; CAFptr; + CAFptr = (P_) IND_CLOSURE_LINK(CAFptr)) { + INFO_PTR(CAFptr) = (W_) Caf_Mark_Upd_info; + } + DEBUG_STRING("Marking CAFs:"); + if (cafs1) { + MRoot = (P_) cafs1; + Mark = (P_) MRoot; + MStack = (P_) _PRMarking_MarkNextCAF_closure; + /*ToDo: debugify */ + miniInterpret((StgFunPtr)_startMarkWorld); + } + if (cafs2) { + MRoot = (P_) cafs2; + Mark = (P_) MRoot; + MStack = (P_) _PRMarking_MarkNextCAF_closure; + /*ToDo: debugify */ + miniInterpret((StgFunPtr)_startMarkWorld); + } + +#endif /* 0 */ + + BitArray = bit_array; + HeapBase = base; + HeapLim = lim; + + DEBUG_STRING("Marking Roots:"); + if (sm->rootno > 0) { + sm_roots_end = (P_) &sm->roots[sm->rootno]; + MRoot = (P_) sm->roots; + Mark = (P_) *MRoot; + MStack = (P_) _PRMarking_MarkNextRoot_closure; +#if defined(__STG_TAILJUMPS__) + miniInterpret((StgFunPtr)_startMarkWorld); +#else + if (doSanityChks) + miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL); + else + miniInterpret((StgFunPtr)_startMarkWorld); +#endif /* ! tail-jumping */ + } + +#ifdef CONCURRENT + for(pool = 0; pool < SPARK_POOLS; pool++) { + if (PendingSparksHd[pool] < PendingSparksTl[pool]) { + sm_roots_end = (P_) PendingSparksTl[pool]; + MRoot = (P_) PendingSparksHd[pool]; + Mark = (P_) *MRoot; + MStack = (P_) _PRMarking_MarkNextSpark_closure; +#if defined(__STG_TAILJUMPS__) + miniInterpret((StgFunPtr)_startMarkWorld); +#else + if (doSanityChks) + miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL); + else + miniInterpret((StgFunPtr)_startMarkWorld); +#endif /* ! tail-jumping */ + } + } +#endif + +#ifdef PAR + DEBUG_STRING("Marking GA Roots:"); + MRoot = (P_) liveIndirections; + while(MRoot != NULL && ((GALA *)MRoot)->ga.weight == MAX_GA_WEIGHT) + MRoot = (P_) ((GALA *)MRoot)->next; + if (MRoot != NULL) { + Mark = ((GALA *)MRoot)->la; + MStack = (P_) _PRMarking_MarkNextGA_closure; +#if defined(__STG_TAILJUMPS__) + miniInterpret((StgFunPtr) _startMarkWorld); +#else + if (doSanityChks) + miniInterpret_debug((StgFunPtr) _startMarkWorld, NULL); + else + miniInterpret((StgFunPtr) _startMarkWorld); +#endif /* ! tail-jumping */ + } +#else + /* Note: no *external* stacks in parallel world */ + DEBUG_STRING("Marking A Stack:"); + if (SUBTRACT_A_STK(MAIN_SpA, stackInfo.botA) >= 0) { + MRoot = (P_) MAIN_SpA; + Mark = (P_) *MRoot; + MStack = (P_) _PRMarking_MarkNextAStack_closure; +#if defined(__STG_TAILJUMPS__) + miniInterpret((StgFunPtr)_startMarkWorld); +#else + if (doSanityChks) + miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL); + else + miniInterpret((StgFunPtr)_startMarkWorld); +#endif /* ! tail-jumping */ + } + + DEBUG_STRING("Marking B Stack:"); + if (SUBTRACT_B_STK(MAIN_SuB, stackInfo.botB) > 0) { + MRoot = MAIN_SuB; + Mark = GRAB_UPDATEE(MRoot); + MStack = (P_) _PRMarking_MarkNextBStack_closure; + miniInterpret((StgFunPtr)_startMarkWorld); + } +#endif /* PAR */ + + DEBUG_STRING("Marking & Updating CAFs:"); + if (cafs1) { + MRoot = cafs1; + Mark = (P_) IND_CLOSURE_PTR(MRoot); + MStack = (P_) _PRMarking_MarkNextCAF_closure; +#if defined(__STG_TAILJUMPS__) + miniInterpret((StgFunPtr)_startMarkWorld); +#else + if (doSanityChks) + miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL); + else + miniInterpret((StgFunPtr)_startMarkWorld); +#endif /* ! tail-jumping */ + } + + if (cafs2) { + MRoot = cafs2; + Mark = (P_) IND_CLOSURE_PTR(MRoot); + MStack = (P_) _PRMarking_MarkNextCAF_closure; +#if defined(__STG_TAILJUMPS__) + miniInterpret((StgFunPtr)_startMarkWorld); +#else + if (doSanityChks) + miniInterpret_debug((StgFunPtr)_startMarkWorld, NULL); + else + miniInterpret((StgFunPtr)_startMarkWorld); +#endif /* ! tail-jumping */ + } + return 0; +} + +#endif /* _INFO_MARKING */ + +\end{code} + + +CODE REQUIRED (expressed as a loop): + +MARK ROOTS + + MStack = _PRMarking_MarkNextRoot_closure; + for (MRoot = (P_) sm->roots; + MRoot < (P_) &sm->roots[sm->rootno]; + MRoot++) { + Mark = (P_) *MRoot; + (PRMARK_CODE(INFO_PTR(Mark)))(); +_PRMarking_MarkNextRoot: + *MRoot = (W_) Mark; + } + + +MARK AStack + + MStack = _PRMarking_MarkNextAStack_closure; + for (MRoot = MAIN_SpA; + SUBTRACT_A_STK(MRoot, stackInfo.botA) >= 0; + MRoot = MRoot + AREL(1)) { + Mark = (P_) *MRoot; + (PRMARK_CODE(INFO_PTR(Mark)))(); +_PRMarking_MarkNextAStack: + *MRoot = (W_) Mark; + } + + +MARK BStack + + MStack = _PRMarking_MarkNextBStack_closure; + for (MRoot = MAIN_SuB; --- Topmost Update Frame + SUBTRACT_B_STK(MRoot, stackInfo.botB) > 0; + MRoot = GRAB_SuB(MRoot)) { + + Mark = GRAB_UPDATEE(MRoot); + (PRMARK_CODE(INFO_PTR(Mark)))(); +_PRMarking_MarkNextBStack: + PUSH_UPDATEE(MRoot, Mark); + } + + +MARK CAFs + + MStack = _PRMarking_MarkNextCAF_closure; + for (MRoot = sm->CAFlist; + MRoot; + MRoot = (P_) IND_CLOSURE_LINK(MRoot)) + + Mark = IND_CLOSURE_PTR(MRoot); + (PRMARK_CODE(INFO_PTR(Mark)))(); +_PRMarking_MarkNextCAF: + IND_CLOSURE_PTR(MRoot) = (W_) Mark; + } diff --git a/ghc/runtime/storage/SMscan.lc b/ghc/runtime/storage/SMscan.lc new file mode 100644 index 0000000000..35f1b056e6 --- /dev/null +++ b/ghc/runtime/storage/SMscan.lc @@ -0,0 +1,1695 @@ +/************************************************************************* + SCANNING CODE + +This file contains the basic routines required for inplace compacting +garbage collection. It is based on Jonkers's algorithm. + +There is a compacting routine as well as all the basic routines which +are placed in the info tables of the appropriate closures. + + ToDo: Remove Fillers -- Compiler + Remove Dummy Filler Macros -- SMupdate.lh + Remove special "shrinking" info_upd stuff -- Compiler + Remove special "shrinking" info_upd stuff -- SMinterface.lh + + Updateable closure size can now be relaxed + MinUpdSize is now 1 + May want to allocate larger closures to enable updates inplace + eg Int 1 MkInt etc fit + List 2 Nil,List fit + STree 3 Leaf(2) Branch(3) fit + STree 2 Leaf(2) fits, Branch(3) fails + Tuple4 1 MkTuple4 fails + + Need BHs of appropriate sizes (reserve BHed space for update) + For Appel will require BH_1 to grow to size 2 when collected. + +*************************************************************************/ + +\begin{code} + +#define SCAN_REG_MAP +#include "SMinternal.h" + +#if defined(_INFO_COMPACTING) + +/* Define appropriate global variables as potential register variables */ +/* Assume GC code saves and restores global registers used */ + +RegisterTable ScanRegTable; + +#ifndef PAR +/* As we perform compaction, those CHP's which are still alive get + added to this list. [ADR] */ +StgPtr NewMallocPtrList; +#endif /* !PAR */ + +P_ +Inplace_Compaction(base, lim, scanbase, scanlim, bit_array, bit_array_words +#ifndef PAR +, MallocPtrList +#endif +) + P_ base; + P_ lim; + P_ scanbase; + P_ scanlim; + BitWord *bit_array; + I_ bit_array_words; +#ifndef PAR + StgPtr *MallocPtrList; +#endif +{ + BitWord *bit_array_ptr, *bit_array_end; + P_ scan_w_start, info; I_ size; + + LinkLim = lim; /* Only checked for generational collection */ + +#if defined(GCgn) + + /* Scan collected new gen semi-space linking pointers to old gen */ + /* No closures to unlink (no new ptrs will be linked) */ + /* Have to reset closure to unmarked if it has been marked */ + /* If not marked, we will still link (and unlink) as we need to */ + /* get the size to find next closure. */ + /* It will be collected next minor collection as no root exists*/ + + DEBUG_SCAN("Scan Link Area: Base", scanbase, "Lim", scanlim); + + Scan = scanbase; + New = 0; /* unused -- except by debugging message */ + + while (Scan < scanlim) { + info = (P_) UNMARK_LOCATION(INFO_PTR(Scan)); + Scan += (*SCAN_LINK_CODE(info))(); + } +#endif /* GCgn */ + + DEBUG_SCAN("Scan Link Bits: Base", base, "Bits", bit_array); + + bit_array_ptr = bit_array; + bit_array_end = bit_array + bit_array_words; + scan_w_start = base; + New = base; /* used to unwind */ + +#ifndef PAR + NewMallocPtrList = NULL; /* initialise new MallocPtrList */ + /* As we move MallocPtrs over, we'll add them to this list. */ +#endif /* !PAR */ + + while (bit_array_ptr < bit_array_end) { + BitWord w = *(bit_array_ptr++); + + Scan = scan_w_start; + while (w) { + + if (! (w & 0x1)) { /* bit not set */ + Scan++; /* look at next bit */ + w >>= 1; + + } else { /* Bit Set -- Enter ScanLink for closure */ + info = (P_) INFO_PTR(Scan); + while (MARKED_LOCATION(info)) { + P_ next; + info = UNMARK_LOCATION(info); + next = (P_) *info; + DEBUG_UNLINK_LOCATION(info, Scan, New); + *info = (W_) New; + info = next; + } + INFO_PTR(Scan) = (W_) info; +/* +if (SM_trace & 8) { + fprintf(stderr, " Marked: word %ld, val 0x%lx, cur 0x%lx, Scan_w 0x%lx, Scan 0x%lx, Info 0x%lx, Code 0x%lx\n", + (bit_array_ptr-1) - bit_array, *(bit_array_ptr-1), w, scan_w_start, Scan, info, + SCAN_LINK_CODE(info)); }; +*/ + + size = (*SCAN_LINK_CODE(info))(); + + ASSERT( size >= 0 ); + New += size; /* set New address of next closure */ + + Scan += size; /* skip size bits */ + + if (size >= BITS_IN(BitWord)) break; + /* NOTA BENE: if size >= # bits in BitWord, then the result + of this operation is undefined! Hence the need for + this break! */ + w >>= size; + } + } + scan_w_start += BITS_IN(BitWord); + } + DEBUG_SCAN("Scan Link Bits: End", Scan, "New", New); + + bit_array_ptr = bit_array; + bit_array_end = bit_array + bit_array_words; + scan_w_start = base; /* Points to the heap word corresponding to the + first bit of *bit_array_ptr */ + + New = base; /* used to unwind and move */ + + DEBUG_SCAN("Scan Move Bits: Base", base, "Bits", bit_array); + while (bit_array_ptr < bit_array_end) { + + /* Grab bit word and clear (its the last scan) */ + /* Dont need to clear for Appel or Generational major collection */ + /* Why not??? I think it's because they have a pass which zaps all + the bit array to zero. But why do they need it? Or, why + doesn't dual-mode need it? + + It's probably easier just to *always* to zap at the beginning of + GC, and remove this conditional compilation here. */ +#if defined(GCap) || defined(GCgn) + BitWord w = (I_) *(bit_array_ptr++); +#else + BitWord w = (I_) *bit_array_ptr; + *(bit_array_ptr++) = 0; +#endif + + Scan = scan_w_start; + while (w) { + if (! (w & 0x1)) { /* bit not set */ + Scan++; /* look at next bit */ + w >>= 1; + + } else { /* Bit Set -- Enter ScanMove for closure*/ +/*HACK if (SM_trace&8) {fprintf(stderr,"Scan=%x\n",Scan);} */ + info = (P_) INFO_PTR(Scan); +/*HACK if (SM_trace&8) {fprintf(stderr,"info=%x\n",info);} */ + while (MARKED_LOCATION(info)) { + P_ next; + info = UNMARK_LOCATION(info); + next = (P_) *info; +/*HACK if (SM_trace&8) {fprintf(stderr,"next=%x\n",next);} */ + DEBUG_UNLINK_LOCATION(info, Scan, New); +/*HACK if (SM_trace&8) {fprintf(stderr,"New=%x\n",New);} */ + *info = (W_) New; + info = next; +/*HACK if (SM_trace&8) {fprintf(stderr,"*info=%x,info=%x\n",*info,info);} */ + } +/*HACK if (SM_trace&8) {fprintf(stderr,"preNew info=%x\n",info);} */ + INFO_PTR(New) = (W_) info; + +/* +if (SM_trace & 8) { + fprintf(stderr, " Marked: word %ld, cur 0x%lx, Scan_w 0x%lx, Scan 0x%lx, Info 0x%lx, Code 0x%lx\n", + (bit_array_ptr-1) - bit_array, w, scan_w_start, Scan, info, SCAN_MOVE_CODE(info)); }; +*/ + + size = (*SCAN_MOVE_CODE(info))(); + New += size; /* set New address of next closure */ + Scan += size; /* skip size bits */ + + if (size >= BITS_IN(BitWord)) break; + /* NOTA BENE: if size >= # bits in BitWord, then the result + of this operation is undefined! Hence the need for + this break! */ + w >>= size; /* NB: comment above about shifts */ + } + } + + /* At this point we've exhausted one word of mark bits */ + /* Make scan_w_start point to the heap word corresponding to the + first bit of the next word of mark bits */ + scan_w_start += BITS_IN(BitWord); + } + DEBUG_SCAN("Scan Link Bits: End", Scan, "New", New); + +#ifdef PAR + RebuildLAGAtable(); +#else + VALIDATE_MallocPtrList( NewMallocPtrList ); + *MallocPtrList = NewMallocPtrList; +#endif /* PAR */ + + return(New); +} + +\end{code} + +/************************************************************************* + Basic SCAN LINK and SCAN MOVE Routines + +First Scan on Closures + _ScanLink_S_N + + Retrieved using SCAN_LINK_CODE(infoptr) (for a true unmarked infoptr) + +Links the closure's ptr locations to the info pointer of the closure's +they actually point. Returns the size of the closure so New can be updated +to point to next closure. This also allows sequential scan (if there are no +holes i.e. it has already been collected). + +Must first unwind the locations linked to this closure updating with +the new location of this closure before entering the code. The code +can only be access from the info pointer at the end of this location +list, which must be restored before entering. + + Calling Conventions (After unwinding and updating locations pointed to): + Scan -- points to this closure + LinkLim -- points to end of heap are requiring pointer to be linked + + New (optional) -- points to the new location that this closure will reside + this is only required for meaningful debugging meassge + +Second Scan on Closures + _ScanMove_S + + Retrieved using SCAN_MOVE_CODE(infoptr) (for a true unmarked infoptr) + +Slides the closure down to its new location, New. Returns the size of +the closure so New can be updated to point to the next closure. + +Must first unwind the locations linked to this closure updating with +the new location of this closure before entering the code. The code +can only be access from the info pointer at the end of this location +list, which must be restored before entering. + + Calling Conventions (After unwinding and updating locations pointed to): + Scan -- points to this closure + New -- points to the new location that this closure will reside + + +Will have MARKING routines in info tables as well: + +Marking A Closure: + _PRStart_N + + Retrieved using PRMARK_CODE(infoptr) + +Returning To A Closure Being Marked: + _PRIn_I + _PRInLast_N + + Retrieved using PRRETURN_CODE(infoptr) + + + +May have COPYING routines in info tables as well: + +Evacuation code: _Evacuate_S +Scavenging code: _Scavenge_S_N + + See GCscav.lhc GCevac.lc + + + +The following registers are used by the Compacting collection: + +New -- The new address of a closure +Scan -- The current address of a closure +LinkLim -- The limit of the heap requiring to be linked & moved + +**************************************************************************/ + +\begin{code} + +#if defined(GCgn) +#define LINK_LOCATION(i) LINK_LOCATION_TO_CLOSURE((Scan+(i)),LinkLim) +#else /* ! GCgn */ +#define LINK_LOCATION(i) LINK_LOCATION_TO_CLOSURE(Scan+(i)) +#endif /* ! GCgn */ + +/* Link location of nth pointer in SPEC/STKO closure (starting at 1) */ +#define SPEC_LINK_LOCATION(ptr) LINK_LOCATION((SPEC_HS-1) + (ptr)) +#define STKO_LINK_LOCATION(ptr) LINK_LOCATION((STKO_HS-1) + (ptr)) + + +/* Slide the ith word (starting at 0) */ +#define SLIDE_WORD(position) New[position] = Scan[position] + +/* Slide the ith ptr (starting at 0), adjusting by offset */ +#define ADJUST_WORD(pos,off) ((PP_)New)[pos] += (off) + +/* Slide the nth free var word in a SPEC closure (starting at 1) */ +#define SPEC_SLIDE_WORD(n) SLIDE_WORD((SPEC_HS-1) + (n)) + +#ifndef PAR +/* Don't slide the MallocPtr list link - instead link moved object into + @NewMallocPtrList@ */ + +#define MallocPtr_SLIDE_DATA \ + MallocPtr_CLOSURE_DATA(New) = MallocPtr_CLOSURE_DATA(Scan) +#define MallocPtr_RELINK \ +{ \ + MallocPtr_CLOSURE_LINK(New) = NewMallocPtrList; \ + NewMallocPtrList = New; \ +} +#endif /* !PAR */ + +/* The SLIDE_FIXED_HDR macro is dependent on the No of FIXED_HS */ + +#if FIXED_HS == 1 +#define SLIDE_FIXED_HDR /* Already Assigned INFO_PTR */ +#else +#if FIXED_HS == 2 +#define SLIDE_FIXED_HDR SLIDE_WORD(1) +#else +#if FIXED_HS == 3 +#define SLIDE_FIXED_HDR SLIDE_WORD(1);SLIDE_WORD(2) +#else +/* I don't think this will be needed (ToDo: #error?) */ +#endif +#endif +#endif + + +#if defined(_GC_DEBUG) + +#define DEBUG_SCAN_LINK(type, sizevar, ptrvar) \ + if (SM_trace & 2) \ + fprintf(stderr, "Scan Link (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \ + type, Scan, New, INFO_PTR(Scan), sizevar, ptrvar) + +#define DEBUG_SCAN_MOVE(type, sizevar) \ + if (SM_trace & 2) \ + fprintf(stderr, "Scan Move (%s): 0x%lx -> 0x%lx, info 0x%lx, size %ld\n", \ + type, Scan, New, INFO_PTR(New), sizevar) + + +#else + +#define DEBUG_SCAN_LINK(type, sizevar, ptrvar) +#define DEBUG_SCAN_MOVE(type, sizevar) + +#endif + +/*** LINKING CLOSURES ***/ + +I_ +_ScanLink_1_0(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 1, 0); + return(FIXED_HS + 1); /* SPEC_VHS is defined to be 0, so "size" really is 1 */ +} +I_ +_ScanLink_2_0(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 2, 0); + return(FIXED_HS + 2); +} +I_ +_ScanLink_3_0(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 3, 0); + return(FIXED_HS + 3); +} +I_ +_ScanLink_4_0(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 4, 0); + return(FIXED_HS + 4); +} +I_ +_ScanLink_5_0(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 5, 0); + return(FIXED_HS + 5); +} + +I_ +_ScanLink_2_1(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 2, 1); + SPEC_LINK_LOCATION(1); + return(FIXED_HS + 2); +} +I_ +_ScanLink_3_1(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 3, 1); + SPEC_LINK_LOCATION(1); + return(FIXED_HS + 3); +} +I_ +_ScanLink_3_2(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 3, 2); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + return(FIXED_HS + 3); +} + +I_ +_ScanLink_1_1(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 1, 1); + SPEC_LINK_LOCATION(1); + return(FIXED_HS + 1); +} +I_ +_ScanLink_2_2(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 2, 2); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + return(FIXED_HS + 2); +} +I_ +_ScanLink_3_3(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 3, 3); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + return(FIXED_HS + 3); +} +I_ +_ScanLink_4_4(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 4, 4); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + return(FIXED_HS + 4); +} +I_ +_ScanLink_5_5(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 5, 5); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + return(FIXED_HS + 5); +} +I_ +_ScanLink_6_6(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 6, 6); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + return(FIXED_HS + 6); +} +I_ +_ScanLink_7_7(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 7, 7); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + SPEC_LINK_LOCATION(7); + return(FIXED_HS + 7); +} +I_ +_ScanLink_8_8(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 8, 8); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + SPEC_LINK_LOCATION(7); + SPEC_LINK_LOCATION(8); + return(FIXED_HS + 8); +} +I_ +_ScanLink_9_9(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 9, 9); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + SPEC_LINK_LOCATION(7); + SPEC_LINK_LOCATION(8); + SPEC_LINK_LOCATION(9); + return(FIXED_HS + 9); +} +I_ +_ScanLink_10_10(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 10, 10); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + SPEC_LINK_LOCATION(7); + SPEC_LINK_LOCATION(8); + SPEC_LINK_LOCATION(9); + SPEC_LINK_LOCATION(10); + return(FIXED_HS + 10); +} +I_ +_ScanLink_11_11(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 11, 11); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + SPEC_LINK_LOCATION(7); + SPEC_LINK_LOCATION(8); + SPEC_LINK_LOCATION(9); + SPEC_LINK_LOCATION(10); + SPEC_LINK_LOCATION(11); + return(FIXED_HS + 11); +} +I_ +_ScanLink_12_12(STG_NO_ARGS) { + DEBUG_SCAN_LINK("SPEC", 12, 12); + SPEC_LINK_LOCATION(1); + SPEC_LINK_LOCATION(2); + SPEC_LINK_LOCATION(3); + SPEC_LINK_LOCATION(4); + SPEC_LINK_LOCATION(5); + SPEC_LINK_LOCATION(6); + SPEC_LINK_LOCATION(7); + SPEC_LINK_LOCATION(8); + SPEC_LINK_LOCATION(9); + SPEC_LINK_LOCATION(10); + SPEC_LINK_LOCATION(11); + SPEC_LINK_LOCATION(12); + return(FIXED_HS + 12); +} +\end{code} + +Scan-linking revertible black holes with underlying @SPEC@ closures. + +\begin{code} + +#ifdef PAR +I_ +_ScanLink_RBH_2_1(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 2, 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + return(FIXED_HS + 2); /* ???? but SPEC_RBH_VHS is *not* zero! */ +} + +I_ +_ScanLink_RBH_3_1(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 3, 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + return(FIXED_HS + 3); +} + +I_ +_ScanLink_RBH_3_3(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 3, 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + return(FIXED_HS + 3); +} + +I_ +_ScanLink_RBH_4_1(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 4, 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + return(FIXED_HS + 4); +} + +I_ +_ScanLink_RBH_4_4(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 4, 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + return(FIXED_HS + 4); +} + +I_ +_ScanLink_RBH_5_1(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 5, 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + return(FIXED_HS + 5); +} + +I_ +_ScanLink_RBH_5_5(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 5, 5); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + return(FIXED_HS + 5); +} + +I_ +_ScanLink_RBH_6_6(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 6, 6); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + return(FIXED_HS + 6); +} + +I_ +_ScanLink_RBH_7_7(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 7, 7); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5); + return(FIXED_HS + 7); +} + +I_ +_ScanLink_RBH_8_8(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 8, 8); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6); + return(FIXED_HS + 8); +} + +I_ +_ScanLink_RBH_9_9(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 9, 9); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7); + return(FIXED_HS + 9); +} + +I_ +_ScanLink_RBH_10_10(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 10, 10); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8); + return(FIXED_HS + 10); +} + +I_ +_ScanLink_RBH_11_11(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 11, 11); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9); + return(FIXED_HS + 11); +} + +I_ +_ScanLink_RBH_12_12(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("SRBH", 12, 12); + LINK_LOCATION(SPEC_RBH_BQ_LOCN); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 1); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 2); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 3); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 4); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 5); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 6); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 7); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 8); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 9); + LINK_LOCATION(SPEC_RBH_BQ_LOCN + 10); + return(FIXED_HS + 12); +} +#endif + +\end{code} + +Scan-linking a MallocPtr is straightforward: exactly the same as +@_ScanLink_[MallocPtr_SIZE]_0@. + +\begin{code} +#ifndef PAR +StgInt +_ScanLink_MallocPtr(STG_NO_ARGS) { + DEBUG_SCAN_LINK("MallocPtr", MallocPtr_SIZE, 0); + return(FIXED_HS + MallocPtr_SIZE); +} +#endif /* !PAR */ +\end{code} + +Back to the main feature... + +\begin{code} + +/*** MOVING CLOSURES ***/ + +I_ +_ScanMove_1(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 1); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + return(FIXED_HS + 1); /* NB: SPEC_VHS defined to be zero, so 1 really is the "size" */ +} +I_ +_ScanMove_2(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 2); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + return(FIXED_HS + 2); +} +I_ +_ScanMove_3(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 3); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + return(FIXED_HS + 3); +} +I_ +_ScanMove_4(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 4); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + return(FIXED_HS + 4); +} +I_ +_ScanMove_5(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 5); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + return(FIXED_HS + 5); +} +I_ +_ScanMove_6(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 6); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + return(FIXED_HS + 6); +} +I_ +_ScanMove_7(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 7); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + SPEC_SLIDE_WORD(7); + return(FIXED_HS + 7); +} +I_ +_ScanMove_8(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 8); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + SPEC_SLIDE_WORD(7); + SPEC_SLIDE_WORD(8); + return(FIXED_HS + 8); +} +I_ +_ScanMove_9(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 9); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + SPEC_SLIDE_WORD(7); + SPEC_SLIDE_WORD(8); + SPEC_SLIDE_WORD(9); + return(FIXED_HS + 9); +} +I_ +_ScanMove_10(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 10); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + SPEC_SLIDE_WORD(7); + SPEC_SLIDE_WORD(8); + SPEC_SLIDE_WORD(9); + SPEC_SLIDE_WORD(10); + return(FIXED_HS + 10); +} +I_ +_ScanMove_11(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 11); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + SPEC_SLIDE_WORD(7); + SPEC_SLIDE_WORD(8); + SPEC_SLIDE_WORD(9); + SPEC_SLIDE_WORD(10); + SPEC_SLIDE_WORD(11); + return(FIXED_HS + 11); +} +I_ +_ScanMove_12(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SPEC", 12); + SLIDE_FIXED_HDR; + SPEC_SLIDE_WORD(1); + SPEC_SLIDE_WORD(2); + SPEC_SLIDE_WORD(3); + SPEC_SLIDE_WORD(4); + SPEC_SLIDE_WORD(5); + SPEC_SLIDE_WORD(6); + SPEC_SLIDE_WORD(7); + SPEC_SLIDE_WORD(8); + SPEC_SLIDE_WORD(9); + SPEC_SLIDE_WORD(10); + SPEC_SLIDE_WORD(11); + SPEC_SLIDE_WORD(12); + return(FIXED_HS + 12); +} + +#if defined(PAR) && defined(GC_MUT_REQUIRED) +I_ +_ScanMove_RBH_2(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 2); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 2); /* ???? SPEC_RBH_VHS is *not* zero! */ +} +I_ +_ScanMove_RBH_3(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 3); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 3); +} +I_ +_ScanMove_RBH_4(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 4); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 4); +} +I_ +_ScanMove_RBH_5(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 5); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 5); +} +I_ +_ScanMove_RBH_6(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 6); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 6); +} +I_ +_ScanMove_RBH_7(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 7); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + SLIDE_WORD(SPEC_RBH_HS + 5); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 7); +} +I_ +_ScanMove_RBH_8(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 8); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + SLIDE_WORD(SPEC_RBH_HS + 5); + SLIDE_WORD(SPEC_RBH_HS + 6); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 8); +} +I_ +_ScanMove_RBH_9(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 9); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + SLIDE_WORD(SPEC_RBH_HS + 5); + SLIDE_WORD(SPEC_RBH_HS + 6); + SLIDE_WORD(SPEC_RBH_HS + 7); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 9); +} +I_ +_ScanMove_RBH_10(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 10); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + SLIDE_WORD(SPEC_RBH_HS + 5); + SLIDE_WORD(SPEC_RBH_HS + 6); + SLIDE_WORD(SPEC_RBH_HS + 7); + SLIDE_WORD(SPEC_RBH_HS + 8); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 10); +} +I_ +_ScanMove_RBH_11(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 11); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + SLIDE_WORD(SPEC_RBH_HS + 5); + SLIDE_WORD(SPEC_RBH_HS + 6); + SLIDE_WORD(SPEC_RBH_HS + 7); + SLIDE_WORD(SPEC_RBH_HS + 8); + SLIDE_WORD(SPEC_RBH_HS + 9); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 11); +} +I_ +_ScanMove_RBH_12(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("SRBH", 12); + SLIDE_FIXED_HDR; + SLIDE_WORD(SPEC_RBH_HS + 0); + SLIDE_WORD(SPEC_RBH_HS + 1); + SLIDE_WORD(SPEC_RBH_HS + 2); + SLIDE_WORD(SPEC_RBH_HS + 3); + SLIDE_WORD(SPEC_RBH_HS + 4); + SLIDE_WORD(SPEC_RBH_HS + 5); + SLIDE_WORD(SPEC_RBH_HS + 6); + SLIDE_WORD(SPEC_RBH_HS + 7); + SLIDE_WORD(SPEC_RBH_HS + 8); + SLIDE_WORD(SPEC_RBH_HS + 9); + SLIDE_WORD(SPEC_RBH_HS + 10); + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + 12); +} +#endif +\end{code} + +Moving a Malloc Pointer is a little tricky: we want to copy the actual +pointer unchanged (easy) but we want to link the MallocPtr into the +new MallocPtr list. + +\begin{code} +#ifndef PAR +StgInt +_ScanMove_MallocPtr(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("MallocPtr", MallocPtr_SIZE); + +#if defined(_GC_DEBUG) + if (SM_trace & 16) { + printf("Moving MallocPtr(%x)=<%x,%x,%x>", Scan, Scan[0], Scan[1], Scan[2]); + printf(" Data = %x, Next = %x\n", + MallocPtr_CLOSURE_DATA(Scan), MallocPtr_CLOSURE_LINK(Scan) ); + } +#endif + + SLIDE_FIXED_HDR; + MallocPtr_SLIDE_DATA; + MallocPtr_RELINK; + +#if defined(_GC_DEBUG) + if (SM_trace & 16) { + printf("Moved MallocPtr(%x)=<%x,_,%x,%x,%x>", New, New[0], New[1], New[2], New[3]); + printf(" Data = %x, Next = %x", + MallocPtr_CLOSURE_DATA(New), MallocPtr_CLOSURE_LINK(New) ); + printf(", NewMallocPtrList = %x\n", NewMallocPtrList ); + } +#endif + + return(FIXED_HS + MallocPtr_SIZE); +} +#endif /* !PAR */ +\end{code} + +Now back to the main feature... + +\begin{code} + +/*** GENERIC Linking and Marking Routines */ + +I_ +_ScanLink_S_N(STG_NO_ARGS) { + I_ count = GEN_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + GEN_CLOSURE_NoPTRS(Scan); + /* Offset of last ptr word */ + I_ size = GEN_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_LINK("GEN ", size, ptrs); + while (++count <= ptrs) { + LINK_LOCATION(count); + } + return(FIXED_HS + size); +} + +I_ +_ScanMove_S(STG_NO_ARGS) { + I_ count = FIXED_HS - 1; + I_ size = GEN_CLOSURE_SIZE(New); + + DEBUG_SCAN_MOVE("GEN ", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + return(FIXED_HS + size); +} + +\end{code} + +The linking code for revertible black holes with underlying @GEN@ closures. + +\begin{code} +#ifdef PAR + +I_ +_ScanLink_RBH_N(STG_NO_ARGS) +{ + I_ count = GEN_RBH_HS - 1; /* Offset of first ptr word, less 1 */ + I_ ptrs = GEN_RBH_CLOSURE_NoPTRS(Scan); + I_ size = GEN_RBH_CLOSURE_SIZE(Scan); + + /* + * Get pointer count from original closure and adjust for one pointer + * in the first two words of the RBH. + */ + if (ptrs < 2) + ptrs = 1; + else + ptrs--; + + ptrs += count; /* Offset of last ptr word */ + + DEBUG_SCAN_LINK("GRBH", size, ptrs); + while (++count <= ptrs) { + LINK_LOCATION(count); + } + return(FIXED_HS + size); +} + +#ifdef GC_MUT_REQUIRED + +I_ +_ScanMove_RBH_S(STG_NO_ARGS) { + I_ count = GEN_RBH_HS - 1; + I_ size = GEN_RBH_CLOSURE_SIZE(New); + + DEBUG_SCAN_MOVE("GRBH", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + size); +} + +#endif + +#endif + +\end{code} + +\begin{code} +I_ +_ScanLink_Dyn(STG_NO_ARGS) { + I_ count = DYN_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + DYN_CLOSURE_NoPTRS(Scan); + /* Offset of last ptr word */ + I_ size = DYN_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_LINK("DYN ", size, ptrs-count); + + while (++count <= ptrs) { + LINK_LOCATION(count); + } + return(FIXED_HS + size); +} + +I_ +_ScanMove_Dyn(STG_NO_ARGS) { + I_ count = FIXED_HS - 1; + I_ size = DYN_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_MOVE("DYN ", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + return(FIXED_HS + size); +} + +I_ +_ScanLink_Tuple(STG_NO_ARGS) { + I_ count = TUPLE_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + TUPLE_CLOSURE_NoPTRS(Scan); + /* Offset of last ptr word */ + I_ size = TUPLE_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_LINK("TUPL", size, ptrs-count); + + while (++count <= ptrs) { + LINK_LOCATION(count); + } + return(FIXED_HS + size); +} + +I_ +_ScanMove_Tuple(STG_NO_ARGS) { + I_ count = FIXED_HS - 1; + I_ size = TUPLE_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_MOVE("TUPL", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + return(FIXED_HS + size); +} + +/*** MUTUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/ +/* Only if special GC treatment required */ + +#ifdef GC_MUT_REQUIRED +I_ +_ScanLink_MuTuple(STG_NO_ARGS) { + I_ count = MUTUPLE_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + MUTUPLE_CLOSURE_NoPTRS(Scan); + /* Offset of last ptr word */ + I_ size = MUTUPLE_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_LINK("MUT ", size, ptrs-count); + + while (++count <= ptrs) { + LINK_LOCATION(count); + } + return(FIXED_HS + size); +} + +I_ +_ScanMove_MuTuple(STG_NO_ARGS) { + I_ count = FIXED_HS - 1; + I_ size = MUTUPLE_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_MOVE("MUT ", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; + + return(FIXED_HS + size); +} + +I_ +_ScanMove_ImmuTuple(STG_NO_ARGS) { + I_ count = FIXED_HS - 1; + I_ size = MUTUPLE_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_MOVE("IMUT", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + + /* Dont add to OldMutables list */ + + return(FIXED_HS + size); +} +#endif /* GCap || GCgn */ + + +I_ +_ScanLink_Data(STG_NO_ARGS) { + I_ size = DATA_CLOSURE_SIZE(Scan); + DEBUG_SCAN_LINK("DATA", size, 0); + return(FIXED_HS + size); +} + +I_ +_ScanMove_Data(STG_NO_ARGS) { + I_ count = FIXED_HS - 1; + I_ size = DATA_CLOSURE_SIZE(Scan); + + DEBUG_SCAN_MOVE("DATA", size); + + SLIDE_FIXED_HDR; + while (++count <= size + (FIXED_HS - 1)) { + SLIDE_WORD(count); + } + return(FIXED_HS + size); +} + + +I_ +_ScanLink_BH_U(STG_NO_ARGS) { + DEBUG_SCAN_LINK("BH ", MIN_UPD_SIZE, 0); + return(FIXED_HS + BH_U_SIZE); /* size includes _VHS */ + /* NB: pretty intimate knowledge about BH closure layout */ +} + +I_ +_ScanMove_BH_U(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("BH ", MIN_UPD_SIZE); + SLIDE_FIXED_HDR; + return(FIXED_HS + BH_U_SIZE); + /* ditto */ +} + +I_ +_ScanLink_BH_N(STG_NO_ARGS) { + DEBUG_SCAN_LINK("BH N", MIN_NONUPD_SIZE, 0); + return(FIXED_HS + BH_N_SIZE); /* size includes _VHS */ + /* NB: pretty intimate knowledge about BH closure layout */ +} + +I_ +_ScanMove_BH_N(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("BH N",MIN_NONUPD_SIZE); + SLIDE_FIXED_HDR; + return(FIXED_HS + BH_N_SIZE); + /* ditto */ +} + +#ifdef USE_COST_CENTRES +I_ +_ScanLink_PI(STG_NO_ARGS) { + DEBUG_SCAN_LINK("PI ", IND_CLOSURE_SIZE(dummy), 1); + LINK_LOCATION(IND_HS); + return(FIXED_HS + IND_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/); +} + +I_ +_ScanMove_PI(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("PI ", IND_CLOSURE_SIZE(dummy)); + SLIDE_FIXED_HDR; + SLIDE_WORD(IND_HS); + return(FIXED_HS + IND_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/); +} +#endif + +\end{code} + +Linking and Marking Routines for FetchMes and stack objects. + +\begin{code} + +#if defined(CONCURRENT) + +#if defined(PAR) + +I_ +_ScanLink_FetchMe(STG_NO_ARGS) { + DEBUG_SCAN_LINK("FME ", MIN_UPD_SIZE, 0); + return(FIXED_HS + FETCHME_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/); +} + +I_ +_ScanMove_FetchMe(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("FME ",MIN_UPD_SIZE); + SLIDE_FIXED_HDR; + SLIDE_WORD(FETCHME_GA_LOCN); + ASSERT(GALAlookup(FETCHME_GA(New)) != NULL); + +#ifdef GC_MUT_REQUIRED + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; +#endif + + return(FIXED_HS + FETCHME_CLOSURE_SIZE(dummy) /*MIN_UPD_SIZE*/); +} + +I_ +_ScanLink_BF(STG_NO_ARGS) +{ + DEBUG_SCAN_LINK("BF", BF_HS, 2 /*possibly wrong (WDP 95/07)*/); + + LINK_LOCATION(BF_LINK_LOCN); + LINK_LOCATION(BF_NODE_LOCN); + return(FIXED_HS + BF_CLOSURE_SIZE(dummy)); +} + +I_ +_ScanMove_BF(STG_NO_ARGS) +{ + I_ count; + + SLIDE_FIXED_HDR; + for (count = FIXED_HS; count < FIXED_HS + BF_VHS; count++) { + SLIDE_WORD(count); + } + SLIDE_WORD(BF_LINK_LOCN); + SLIDE_WORD(BF_NODE_LOCN); + SLIDE_WORD(BF_GTID_LOCN); + SLIDE_WORD(BF_SLOT_LOCN); + SLIDE_WORD(BF_WEIGHT_LOCN); + +#ifdef GC_MUT_REQUIRED + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; +#endif + + return(FIXED_HS + BF_CLOSURE_SIZE(dummy)); +} + +#endif /* PAR */ + +I_ +_ScanLink_BQ(STG_NO_ARGS) { + DEBUG_SCAN_LINK("BQ ", BQ_CLOSURE_SIZE(dummy), BQ_CLOSURE_NoPTRS(Scan)); + LINK_LOCATION(BQ_HS); + return(FIXED_HS + BQ_CLOSURE_SIZE(dummy)); +} + +I_ +_ScanMove_BQ(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("BQ ", BQ_CLOSURE_SIZE(dummy)); + + SLIDE_FIXED_HDR; + SLIDE_WORD(BQ_HS); + +#ifdef GC_MUT_REQUIRED + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; +#endif + + return(FIXED_HS + BQ_CLOSURE_SIZE(dummy)); +} + +I_ +_ScanLink_TSO(STG_NO_ARGS) +{ + STGRegisterTable *r = TSO_INTERNAL_PTR(Scan); + W_ liveness = r->rLiveness; + I_ i; + + DEBUG_SCAN_LINK("TSO", TSO_HS + TSO_CTS_SIZE, 0/*wrong*/); + + LINK_LOCATION(TSO_LINK_LOCN); + LINK_LOCATION(((P_) &r->rStkO) - Scan); + for(i = 0; liveness != 0; liveness >>= 1, i++) { + if (liveness & 1) { + LINK_LOCATION(((P_) &r->rR[i].p) - Scan) + } + } + return(TSO_HS + TSO_CTS_SIZE); +} + +I_ +_ScanMove_TSO(STG_NO_ARGS) +{ + I_ count; + + SLIDE_FIXED_HDR; + for (count = FIXED_HS; count < FIXED_HS + TSO_VHS; count++) { + SLIDE_WORD(count); + } + + for(count = 0; count < BYTES_TO_STGWORDS(sizeof(STGRegisterTable)); count++) + /* Do it this way in case there's a shift of just one word */ + ((P_) TSO_INTERNAL_PTR(New))[count] = ((P_) TSO_INTERNAL_PTR(Scan))[count]; + +#ifdef GC_MUT_REQUIRED + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; +#endif + + return(TSO_HS + TSO_CTS_SIZE); +} + +I_ +_ScanLink_StkO(STG_NO_ARGS) { + I_ count; + I_ size = STKO_CLOSURE_SIZE(Scan); + I_ cts_size = STKO_CLOSURE_CTS_SIZE(Scan); + I_ sub = STKO_SuB_OFFSET(Scan); /* Offset of first update frame in B stack */ + + /* Link the link */ + LINK_LOCATION(STKO_LINK_LOCN); + + /* Link the locations in the A stack */ + DEBUG_SCAN_LINK("STKO", size, cts_size - STKO_SpA_OFFSET(SCAN) + 1); + for (count = STKO_SpA_OFFSET(Scan); count <= cts_size; count++) { + STKO_LINK_LOCATION(count); + } + + /* Now link the updatees in the update stack */ + while(sub > 0) { + P_ subptr; + + STKO_LINK_LOCATION(sub + BREL(UF_UPDATEE)); + subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scan,sub)); + sub = STKO_CLOSURE_OFFSET(Scan, subptr); + } + + /* + I assume what's wanted is the size of the object + rather the number of pointers in the object. KH + */ + return(FIXED_HS + size); +} + +/* We move first and then repair, so that we can handle an overlapping source + and destination. + */ + +I_ +_ScanMove_StkO(STG_NO_ARGS) { + I_ count; + I_ size = STKO_CLOSURE_SIZE(Scan); + I_ cts_size = STKO_CLOSURE_CTS_SIZE(Scan); + I_ spa_offset = STKO_SpA_OFFSET(Scan); + I_ spb_offset = STKO_SpB_OFFSET(Scan); + I_ sub_offset = STKO_SuB_OFFSET(Scan); + I_ offset; + + DEBUG_SCAN_MOVE("STKO", size); + + SLIDE_FIXED_HDR; +#ifdef DO_REDN_COUNTING + SLIDE_WORD(STKO_ADEP_LOCN); + SLIDE_WORD(STKO_BDEP_LOCN); +#endif + SLIDE_WORD(STKO_SIZE_LOCN); + SLIDE_WORD(STKO_RETURN_LOCN); + SLIDE_WORD(STKO_LINK_LOCN); + + /* Adjust the four stack pointers...*IN ORDER* */ + offset = New - Scan; + STKO_SuB(New) = STKO_SuB(Scan) + offset; + STKO_SpB(New) = STKO_SpB(Scan) + offset; + STKO_SpA(New) = STKO_SpA(Scan) + offset; + STKO_SuA(New) = STKO_SuA(Scan) + offset; + + /* Slide the B stack */ + for (count = 1; count <= spb_offset; count++) { + SLIDE_WORD((STKO_HS-1) + count); + } + + /* Slide the A stack */ + for (count = spa_offset; count <= cts_size; count++) { + SLIDE_WORD((STKO_HS-1) + count); + } + + /* Repair internal pointers */ + while (sub_offset > 0) { + P_ subptr; + ADJUST_WORD((STKO_HS-1) + sub_offset + BREL(UF_SUA),offset); + ADJUST_WORD((STKO_HS-1) + sub_offset + BREL(UF_SUB),offset); + subptr = GRAB_SuB(STKO_CLOSURE_ADDR(New,sub_offset)); + sub_offset = STKO_CLOSURE_OFFSET(New, subptr); + } + +#ifdef GC_MUT_REQUIRED + /* Build new OldMutables list */ + MUT_LINK(New) = (W_) StorageMgrInfo.OldMutables; + StorageMgrInfo.OldMutables = (P_) New; +#endif + + return(FIXED_HS + size); +} + +#endif /* CONCURRENT */ + +\end{code} + +\begin{code} +#if defined(GCgn) +I_ +_ScanMove_OldRoot(STG_NO_ARGS) { + DEBUG_SCAN_MOVE("OLDR", 2); + SLIDE_FIXED_HDR; + IND_CLOSURE_PTR(New) = IND_CLOSURE_PTR(Scan); + IND_CLOSURE_LINK(New) = (W_) genInfo.OldInNew; + genInfo.OldInNew = New; + genInfo.OldInNewno++; + return(IND_HS + MIN_UPD_SIZE); /* this looks wrong (WDP 95/07) */ +} +#endif /* GCgn */ + +/*** Dummy Entries -- Should not be entered ***/ + +/* Should not be in a .lc file either... --JSM */ + +STGFUN(_Dummy_Static_entry) { + fprintf(stderr,"Called _Dummy_Static_entry\nShould never occur!\n"); + abort(); +} + +STGFUN(_Dummy_Ind_entry) { + fprintf(stderr,"Called _Dummy_Ind_entry\nShould never occur!\n"); + abort(); +} + +STGFUN(_Dummy_Caf_entry) { + fprintf(stderr,"Called _Dummy_Caf_Ind_entry\nShould never occur!\n"); + abort(); +} + +STGFUN(_Dummy_Const_entry) { + fprintf(stderr,"Called _Dummy_Const_entry\nShould never occur!\n"); + abort(); +} + +STGFUN(_Dummy_CharLike_entry) { + fprintf(stderr,"Called _Dummy_CharLike_entry\nShould never occur!\n"); + abort(); +} + +#endif /* _INFO_COMPACTING */ + +\end{code} diff --git a/ghc/runtime/storage/SMscav.lc b/ghc/runtime/storage/SMscav.lc new file mode 100644 index 0000000000..2bc6ab2ebe --- /dev/null +++ b/ghc/runtime/storage/SMscav.lc @@ -0,0 +1,1031 @@ +**************************************************************************** + +The files SMevac.lc and SMscav.lhc contain the basic routines required +for two-space copying garbage collection. + +Two files are required as the evac routines are conventional call/return +routines while the scavenge routines are continuation routines. + +This file SMscav.lhc contains the scavenging routines ... + +**************************************************************************** + + +All the routines are placed in the info tables of the appropriate closures. + + +Evacuation code: _Evacuate_... + +USE: new = EVACUATE_CLOSURE(evac) + +Evacuates a closure of size S words. Note the size excludes the info +and any other preceding fields (eg global address in Grip implementation) +Returns the address of the closures new location via the Evac register. + + Calling Conventions: + arg -- points to the closure + ToHp -- points to the last allocated word in to-space + Return Conventions: + ret -- points to the new address of the closure + ToHp -- points to the last allocated word in to-space + + Example: Cons cell requires _Evacuate_2 + +Scavenging code: _Scavenge_S_N + + Retrieved using SCAV_CODE(infoptr) + +Scavenges a closure of size S words, with N pointers and returns. +If more closures are required to be scavenged the code to +scan the next closure can be called. + + Calling Conventions: + Scav -- points to the current closure + ToHp -- points to the last allocated word in to-space + + OldGen -- Points to end of old generation (Appels collector only) + + Return Conventions: + Scav -- points to the next closure + ToHp -- points to the (possibly new) location of the last allocated word + + Example: Cons cell requires _Scavenge_2_2 + + +The following registers are used by a two-space collection: + +Scav -- Points to the current closure being scavenged + (PS paper = Hscav) + +ToHp -- Points to the last word allocated in two-space + (PS paper = Hnext) + +A copying pass is started by: + -- Setting ToHp to 1 before the start of to-space + -- Evacuating the roots pointing into from-space + -- root = EVACUATE_CLOSURE(root) + -- Setting Scav to point to the first closure in to-space + -- Execute while (Scav <= ToHp) (SCAV_CODE(INFO_PTR(Scav)))(); + +When Done ToHp will point to the last word allocated in to-space + + +\begin{code} +/* The #define and #include come before the test because SMinternal.h + will suck in includes/SMinterface whcih defines (or doesn't) + _INFO_COPYING [ADR] */ + +#define SCAV_REG_MAP +#include "SMinternal.h" + +#if defined(_INFO_COPYING) + +RegisterTable ScavRegTable; + +/* Moves Scav to point at the info pointer of the next closure to Scavenge */ +#define NEXT_Scav(size) Scav += (size) + FIXED_HS + +/* + When doing a new generation copy collection for Appel's collector + only evacuate references that point to the new generation. + OldGen must be set to point to the end of old space. +*/ + +#if defined(GCgn) + +#define DO_EVACUATE(closure, pos) \ + { P_ evac = (P_) *(((P_)(closure))+(pos)); \ + if (evac > OldGen) { \ + *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); \ + }} + +#else +#if defined(GCap) + +#define DO_EVACUATE(closure, pos) \ + { P_ evac = (P_) *(((P_)(closure))+(pos)); \ + if (evac > OldGen) { \ + *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); \ + }} + +#else /* ! GCgn && ! GCap */ + +#define DO_EVACUATE(closure, pos) \ + { P_ evac = (P_) *(((P_)(closure))+(pos)); \ + *(((P_)(closure))+(pos)) = (W_) EVACUATE_CLOSURE(evac); } + +#endif /* ! GCgn && ! GCap */ +#endif + + +/* Evacuate nth pointer in SPEC closure (starting at 1) */ +#define SPEC_DO_EVACUATE(ptr) DO_EVACUATE(Scav, (SPEC_HS-1) + (ptr)) +#define STKO_DO_EVACUATE(ptr) DO_EVACUATE(Scav, (STKO_HS-1) + (ptr)) + + +/*** DEBUGGING MACROS ***/ + +#if defined(_GC_DEBUG) + +#define DEBUG_SCAV(s,p) \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), s, p) + +#define DEBUG_SCAV_GEN(s,p) \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, Gen info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), s, p) + +#define DEBUG_SCAV_DYN \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, Dyn info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), DYN_CLOSURE_SIZE(Scav), DYN_CLOSURE_NoPTRS(Scav)) + +#define DEBUG_SCAV_TUPLE \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, Tuple info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), TUPLE_CLOSURE_SIZE(Scav), TUPLE_CLOSURE_NoPTRS(Scav)) + +#define DEBUG_SCAV_MUTUPLE \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, MuTuple info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), MUTUPLE_CLOSURE_SIZE(Scav), MUTUPLE_CLOSURE_NoPTRS(Scav)) + +#define DEBUG_SCAV_DATA \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, Data info 0x%lx, size %ld\n", \ + Scav, INFO_PTR(Scav), DATA_CLOSURE_SIZE(Scav)) + +#define DEBUG_SCAV_BH(s) \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, BH info 0x%lx, size %ld\n", \ + Scav, INFO_PTR(Scav), s) + +#define DEBUG_SCAV_IND \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, IND info 0x%lx, size %ld\n", \ + Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav)) + +#define DEBUG_SCAV_PERM_IND \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, PI info 0x%lx, size %ld\n", \ + Scav, INFO_PTR(Scav), IND_CLOSURE_SIZE(Scav)) + +#define DEBUG_SCAV_OLDROOT(s) \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: OLDROOT 0x%lx, info 0x%lx, size %ld\n", \ + Scav, INFO_PTR(Scav), s) + +#ifdef CONCURRENT +#define DEBUG_SCAV_BQ \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, BQ info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), BQ_CLOSURE_SIZE(Scav), BQ_CLOSURE_NoPTRS(Scav)) + +#define DEBUG_SCAV_TSO \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav TSO: 0x%lx\n", \ + Scav) + +#define DEBUG_SCAV_STKO \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav StkO: 0x%lx\n", \ + Scav) + +# ifdef PAR +# define DEBUG_SCAV_BF \ + if (SM_trace & 2) \ + fprintf(stderr, "Scav: 0x%lx, BF info 0x%lx, size %ld, ptrs %ld\n", \ + Scav, INFO_PTR(Scav), BF_CLOSURE_SIZE(dummy), 0) +# endif +#endif + +#else + +#define DEBUG_SCAV(s,p) +#define DEBUG_SCAV_GEN(s,p) +#define DEBUG_SCAV_DYN +#define DEBUG_SCAV_TUPLE +#define DEBUG_SCAV_MUTUPLE +#define DEBUG_SCAV_DATA +#define DEBUG_SCAV_BH(s) +#define DEBUG_SCAV_IND +#define DEBUG_SCAV_PERM_IND +#define DEBUG_SCAV_OLDROOT(s) + +#ifdef CONCURRENT +# define DEBUG_SCAV_BQ +# define DEBUG_SCAV_TSO +# define DEBUG_SCAV_STKO +# ifdef PAR +# define DEBUG_SCAV_BF +# endif +#endif + +#endif + +#define PROFILE_CLOSURE(closure,size) \ + HEAP_PROFILE_CLOSURE(closure,size); \ + LIFE_PROFILE_CLOSURE(closure,size) + +/*** SPECIALISED CODE ***/ + +void +_Scavenge_1_0(STG_NO_ARGS) +{ + DEBUG_SCAV(1,0); + PROFILE_CLOSURE(Scav,1); + NEXT_Scav(1); /* because "size" is defined to be 1 (size SPEC_VHS == 0) */ + return; +} +void +_Scavenge_2_0(STG_NO_ARGS) +{ + DEBUG_SCAV(2,0); + PROFILE_CLOSURE(Scav,2); + NEXT_Scav(2); + return; +} +void +_Scavenge_3_0(STG_NO_ARGS) +{ + DEBUG_SCAV(3,0); + PROFILE_CLOSURE(Scav,3); + NEXT_Scav(3); + return; +} +void +_Scavenge_4_0(STG_NO_ARGS) +{ + DEBUG_SCAV(4,0); + PROFILE_CLOSURE(Scav,4); + NEXT_Scav(4); + return; +} +void +_Scavenge_5_0(STG_NO_ARGS) +{ + DEBUG_SCAV(5,0); + PROFILE_CLOSURE(Scav,5); + NEXT_Scav(5); + return; +} + +void +_Scavenge_2_1(STG_NO_ARGS) +{ + DEBUG_SCAV(2,1); + PROFILE_CLOSURE(Scav,2); + SPEC_DO_EVACUATE(1); + NEXT_Scav(2); + return; +} + +void +_Scavenge_3_1(STG_NO_ARGS) +{ + DEBUG_SCAV(3,1); + PROFILE_CLOSURE(Scav,3); + SPEC_DO_EVACUATE(1); + NEXT_Scav(3); + return; +} +void +_Scavenge_3_2(STG_NO_ARGS) +{ + DEBUG_SCAV(3,2); + PROFILE_CLOSURE(Scav,3); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + NEXT_Scav(3); + return; +} + +void +_Scavenge_1_1(STG_NO_ARGS) +{ + DEBUG_SCAV(1,1); + PROFILE_CLOSURE(Scav,1); + SPEC_DO_EVACUATE(1); + NEXT_Scav(1); + return; +} +void +_Scavenge_2_2(STG_NO_ARGS) +{ + DEBUG_SCAV(2,2); + PROFILE_CLOSURE(Scav,2); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + NEXT_Scav(2); + return; +} +void +_Scavenge_3_3(STG_NO_ARGS) +{ + DEBUG_SCAV(3,3); + PROFILE_CLOSURE(Scav,3); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + NEXT_Scav(3); + return; +} +void +_Scavenge_4_4(STG_NO_ARGS) +{ + DEBUG_SCAV(4,4); + PROFILE_CLOSURE(Scav,4); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + NEXT_Scav(4); + return; +} +void +_Scavenge_5_5(STG_NO_ARGS) +{ + DEBUG_SCAV(5,5); + PROFILE_CLOSURE(Scav,5); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + NEXT_Scav(5); + return; +} +void +_Scavenge_6_6(STG_NO_ARGS) +{ + DEBUG_SCAV(6,6); + PROFILE_CLOSURE(Scav,6); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + NEXT_Scav(6); + return; +} +void +_Scavenge_7_7(STG_NO_ARGS) +{ + DEBUG_SCAV(7,7); + PROFILE_CLOSURE(Scav,7); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + SPEC_DO_EVACUATE(7); + NEXT_Scav(7); + return; +} +void +_Scavenge_8_8(STG_NO_ARGS) +{ + DEBUG_SCAV(8,8); + PROFILE_CLOSURE(Scav,8); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + SPEC_DO_EVACUATE(7); + SPEC_DO_EVACUATE(8); + NEXT_Scav(8); + return; +} +void +_Scavenge_9_9(STG_NO_ARGS) +{ + DEBUG_SCAV(9,9); + PROFILE_CLOSURE(Scav,9); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + SPEC_DO_EVACUATE(7); + SPEC_DO_EVACUATE(8); + SPEC_DO_EVACUATE(9); + NEXT_Scav(9); + return; +} +void +_Scavenge_10_10(STG_NO_ARGS) +{ + DEBUG_SCAV(10,10); + PROFILE_CLOSURE(Scav,10); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + SPEC_DO_EVACUATE(7); + SPEC_DO_EVACUATE(8); + SPEC_DO_EVACUATE(9); + SPEC_DO_EVACUATE(10); + NEXT_Scav(10); + return; +} +void +_Scavenge_11_11(STG_NO_ARGS) +{ + DEBUG_SCAV(11,11); + PROFILE_CLOSURE(Scav,11); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + SPEC_DO_EVACUATE(7); + SPEC_DO_EVACUATE(8); + SPEC_DO_EVACUATE(9); + SPEC_DO_EVACUATE(10); + SPEC_DO_EVACUATE(11); + NEXT_Scav(11); + return; +} +void +_Scavenge_12_12(STG_NO_ARGS) +{ + DEBUG_SCAV(12,12); + PROFILE_CLOSURE(Scav,12); + SPEC_DO_EVACUATE(1); + SPEC_DO_EVACUATE(2); + SPEC_DO_EVACUATE(3); + SPEC_DO_EVACUATE(4); + SPEC_DO_EVACUATE(5); + SPEC_DO_EVACUATE(6); + SPEC_DO_EVACUATE(7); + SPEC_DO_EVACUATE(8); + SPEC_DO_EVACUATE(9); + SPEC_DO_EVACUATE(10); + SPEC_DO_EVACUATE(11); + SPEC_DO_EVACUATE(12); + NEXT_Scav(12); + return; +} +\end{code} + +The scavenge routines for revertible black holes with underlying @SPEC@ +closures. + +\begin{code} + +#ifdef PAR + +# if defined(GCgn) + +# define SCAVENGE_SPEC_RBH_N_1(n) \ +void \ +CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS) \ +{ \ + P_ save_Scav; \ + DEBUG_SCAV(n,1); \ + save_Scav = Scav; \ + Scav = OldGen + 1; \ + DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN); \ + Scav = save_Scav; \ + PROFILE_CLOSURE(Scav,n); \ + NEXT_Scav(n); /* ToDo: dodgy size WDP 95/07 */ \ +} + +# define SCAVENGE_SPEC_RBH_N_N(n) \ +void \ +CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \ +{ \ + int i; \ + P_ save_Scav; \ + DEBUG_SCAV(n,n-1); \ + save_Scav = Scav; \ + Scav = OldGen + 1; \ + for(i = 0; i < n - 1; i++) { \ + DO_EVACUATE(save_Scav, SPEC_RBH_BQ_LOCN + i); \ + } \ + Scav = save_Scav; \ + PROFILE_CLOSURE(Scav,n); \ + NEXT_Scav(n); \ +} + +# else + +# define SCAVENGE_SPEC_RBH_N_1(n) \ +void \ +CAT3(_Scavenge_RBH_,n,_1)(STG_NO_ARGS) \ +{ \ + DEBUG_SCAV(n,1); \ + DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN);\ + PROFILE_CLOSURE(Scav,n); \ + NEXT_Scav(n); \ +} + +# define SCAVENGE_SPEC_RBH_N_N(n) \ +void \ +CAT4(_Scavenge_RBH_,n,_,n)(STG_NO_ARGS) \ +{ \ + int i; \ + DEBUG_SCAV(n,n-1); \ + for(i = 0; i < n - 1; i++) { \ + DO_EVACUATE(Scav, SPEC_RBH_BQ_LOCN + i); \ + } \ + PROFILE_CLOSURE(Scav,n); \ + NEXT_Scav(n); \ +} + +# endif + +SCAVENGE_SPEC_RBH_N_1(2) + +SCAVENGE_SPEC_RBH_N_1(3) +SCAVENGE_SPEC_RBH_N_N(3) + +SCAVENGE_SPEC_RBH_N_1(4) +SCAVENGE_SPEC_RBH_N_N(4) + +SCAVENGE_SPEC_RBH_N_1(5) +SCAVENGE_SPEC_RBH_N_N(5) + +SCAVENGE_SPEC_RBH_N_N(6) +SCAVENGE_SPEC_RBH_N_N(7) +SCAVENGE_SPEC_RBH_N_N(8) +SCAVENGE_SPEC_RBH_N_N(9) +SCAVENGE_SPEC_RBH_N_N(10) +SCAVENGE_SPEC_RBH_N_N(11) +SCAVENGE_SPEC_RBH_N_N(12) + +#endif + +\end{code} + +\begin{code} + +#ifndef PAR +/*** Malloc POINTER -- NOTHING TO SCAVENGE ***/ + +/* (The MallocPtrList is updated at the end of GC and any unevacuated + MallocPtrs reported to C World) [ADR] +*/ + +void +_Scavenge_MallocPtr(STG_NO_ARGS) +{ + DEBUG_SCAV(MallocPtr_SIZE,0); + PROFILE_CLOSURE(Scav,MallocPtr_SIZE); + NEXT_Scav(MallocPtr_SIZE); + return; +} +#endif /* !PAR */ + +/*** GENERAL CASE CODE ***/ + +void +_Scavenge_S_N(STG_NO_ARGS) +{ + I_ count = GEN_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + GEN_CLOSURE_NoPTRS(Scav); + /* Offset of last ptr word */ + I_ size = GEN_CLOSURE_SIZE(Scav); + + DEBUG_SCAV_GEN(size, GEN_CLOSURE_NoPTRS(Scav)); + + while (++count <= ptrs) { + DO_EVACUATE(Scav, count); + } + PROFILE_CLOSURE(Scav,size); + NEXT_Scav(size); + return; +} + +\end{code} + +The scavenge code for revertible black holes with underlying @GEN@ closures + +\begin{code} + +#ifdef PAR + +void +_Scavenge_RBH_N(STG_NO_ARGS) +{ +#if defined(GCgn) + P_ save_Scav; +#endif + + I_ count = GEN_RBH_HS - 1; /* Offset of first ptr word, less 1 */ + I_ ptrs = GEN_RBH_CLOSURE_NoPTRS(Scav); + I_ size = GEN_RBH_CLOSURE_SIZE(Scav); + + /* + * Get pointer count from original closure and adjust for one pointer + * in the first two words of the RBH. + */ + if (ptrs < 2) + ptrs = 1; + else + ptrs--; + + ptrs += count; /* Offset of last ptr word */ + + DEBUG_SCAV_GEN(size, ptrs); + +#if defined(GCgn) + /* No old generation roots should be created for mutable */ + /* pointer fields as they will be explicitly collected */ + /* Ensure this by pointing Scav at the new generation */ + save_Scav = Scav; + Scav = OldGen + 1; + + while (++count <= ptrs) { + DO_EVACUATE(save_Scav, count); + } + Scav = save_Scav; +#else + while (++count <= ptrs) { + DO_EVACUATE(Scav, count); + } +#endif + + PROFILE_CLOSURE(Scav,size); + NEXT_Scav(size); + return; +} + +#endif + +\end{code} + +\begin{code} + +/*** DYNAMIC CLOSURE -- SIZE & PTRS STORED IN CLOSURE ***/ + +void +_Scavenge_Dyn(STG_NO_ARGS) +{ + I_ count = DYN_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + DYN_CLOSURE_NoPTRS(Scav); + /* Offset of last ptr word */ + I_ size = DYN_CLOSURE_SIZE(Scav); + + DEBUG_SCAV_DYN; + while (++count <= ptrs) { + DO_EVACUATE(Scav, count); + } + PROFILE_CLOSURE(Scav,size); + NEXT_Scav(size); + return; +} + +/*** TUPLE CLOSURE -- NO PTRS STORED IN CLOSURE -- NO DATA ***/ + +void +_Scavenge_Tuple(STG_NO_ARGS) +{ + I_ count = TUPLE_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + TUPLE_CLOSURE_NoPTRS(Scav); + /* Offset of last ptr word */ + I_ size = TUPLE_CLOSURE_SIZE(Scav); + + DEBUG_SCAV_TUPLE; + while (++count <= ptrs) { + DO_EVACUATE(Scav, count); + } + PROFILE_CLOSURE(Scav,size); + NEXT_Scav(size); + return; +} + +/*** DATA CLOSURE -- SIZE STORED IN CLOSURE -- NO POINTERS ***/ + +void +_Scavenge_Data(STG_NO_ARGS) +{ + I_ size = DATA_CLOSURE_SIZE(Scav); + + DEBUG_SCAV_DATA; + PROFILE_CLOSURE(Scav,size); + NEXT_Scav(size); + return; +} + +/*** MUTUPLE CLOSURE -- ONLY PTRS STORED IN CLOSURE -- NO DATA ***/ +/* Only if special GC treatment required */ + +#ifdef GC_MUT_REQUIRED +void +_Scavenge_MuTuple(STG_NO_ARGS) +{ +#if defined(GCgn) + P_ save_Scav; +#endif + I_ count = MUTUPLE_HS - 1; + /* Offset of first ptr word, less 1 */ + I_ ptrs = count + MUTUPLE_CLOSURE_NoPTRS(Scav); + /* Offset of last ptr word */ + I_ size = MUTUPLE_CLOSURE_SIZE(Scav); + + DEBUG_SCAV_MUTUPLE; + +#if defined(GCgn) + /* No old generation roots should be created for mutable */ + /* pointer fields as they will be explicitly collected */ + /* Ensure this by pointing Scav at the new generation */ + save_Scav = Scav; + Scav = OldGen + 1; + while (++count <= ptrs) { + DO_EVACUATE(save_Scav, count); + } + Scav = save_Scav; +#else /* GCap */ + while (++count <= ptrs) { + DO_EVACUATE(Scav, count); + } +#endif /* GCap */ + + PROFILE_CLOSURE(Scav,size); + NEXT_Scav(size); + return; +} +#endif /* something generational */ + +/*** BH CLOSURES -- NO POINTERS ***/ + +void +_Scavenge_BH_U(STG_NO_ARGS) +{ + DEBUG_SCAV_BH(BH_U_SIZE); + PROFILE_CLOSURE(Scav,BH_U_SIZE); + NEXT_Scav(BH_U_SIZE); + return; +} + +void +_Scavenge_BH_N(STG_NO_ARGS) +{ + DEBUG_SCAV_BH(BH_N_SIZE); + PROFILE_CLOSURE(Scav,BH_N_SIZE); + NEXT_Scav(BH_N_SIZE); + return; +} + +/* This is needed for scavenging the indirections on the OldMutables list */ + +void +_Scavenge_Ind(STG_NO_ARGS) +{ + DEBUG_SCAV_IND; + PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy)); + DO_EVACUATE(Scav, IND_HS); + NEXT_Scav(IND_CLOSURE_SIZE(dummy)); + return; +} + +void +_Scavenge_Caf(STG_NO_ARGS) +{ + DEBUG_SCAV_IND; + PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy)); + DO_EVACUATE(Scav, IND_HS); + NEXT_Scav(IND_CLOSURE_SIZE(dummy)); + return; +} + +#if defined(USE_COST_CENTRES) + +/* Special permanent indirection for lexical scoping. + As for _Scavenge_Ind but no PROFILE_CLOSURE. +*/ + +void +_Scavenge_PI(STG_NO_ARGS) +{ + DEBUG_SCAV_PERM_IND; + /* PROFILE_CLOSURE(Scav,IND_CLOSURE_SIZE(dummy)); */ + DO_EVACUATE(Scav, IND_HS); + NEXT_Scav(IND_CLOSURE_SIZE(dummy)); + return; +} +#endif /* USE_COST_CENTRES */ + +#ifdef CONCURRENT + +void +_Scavenge_BQ(STG_NO_ARGS) +{ +#if defined(GCgn) + P_ save_Scav; +#endif + + DEBUG_SCAV_BQ; + +#if defined(GCgn) + /* No old generation roots should be created for mutable */ + /* pointer fields as they will be explicitly collected */ + /* Ensure this by pointing Scav at the new generation */ + save_Scav = Scav; + Scav = OldGen + 1; + DO_EVACUATE(save_Scav, BQ_HS); + Scav = save_Scav; +#else /* !GCgn */ + DO_EVACUATE(Scav, BQ_HS); +#endif /* GCgn */ + + PROFILE_CLOSURE(Scav,BQ_CLOSURE_SIZE(dummy)); + NEXT_Scav(BQ_CLOSURE_SIZE(dummy)); + return; +} + +void +_Scavenge_TSO(STG_NO_ARGS) +{ +#if defined(GCgn) + P_ save_Scav; +#endif + STGRegisterTable *r = TSO_INTERNAL_PTR(Scav); + W_ liveness = r->rLiveness; + I_ i; + + DEBUG_SCAV_TSO; + +#if defined(GCgn) + /* No old generation roots should be created for mutable */ + /* pointer fields as they will be explicitly collected */ + /* Ensure this by pointing Scav at the new generation */ + save_Scav = Scav; + Scav = OldGen + 1; + + DO_EVACUATE(save_Scav, TSO_LINK_LOCN); + DO_EVACUATE(save_Scav, ((P_) &r->rStkO) - save_Scav); + for(i = 0; liveness != 0; liveness >>= 1, i++) { + if (liveness & 1) { + DO_EVACUATE(save_Scav, ((P_) &r->rR[i].p) - save_Scav) + } + } + Scav = save_Scav; +#else + DO_EVACUATE(Scav, TSO_LINK_LOCN); + DO_EVACUATE(Scav, ((P_) &r->rStkO) - Scav); + for(i = 0; liveness != 0; liveness >>= 1, i++) { + if (liveness & 1) { + DO_EVACUATE(Scav, ((P_) &r->rR[i].p) - Scav) + } + } +#endif + + PROFILE_CLOSURE(Scav, TSO_VHS + TSO_CTS_SIZE) + NEXT_Scav(TSO_VHS + TSO_CTS_SIZE); + return; +} + +void +_Scavenge_StkO(STG_NO_ARGS) +{ +#if defined(GCgn) + P_ save_Scav; +#endif + I_ count; + I_ sub = STKO_SuB_OFFSET(Scav); /* Offset of first update frame in B stack */ + + DEBUG_SCAV_STKO; + +#if defined(GCgn) + /* No old generation roots should be created for mutable */ + /* pointer fields as they will be explicitly collected */ + /* Ensure this by pointing Scav at the new generation */ + save_Scav = Scav; + Scav = OldGen + 1; + + /* Evacuate the link */ + DO_EVACUATE(save_Scav, STKO_LINK_LOCN); + + /* Evacuate the locations in the A stack */ + for (count = STKO_SpA_OFFSET(save_Scav); + count <= STKO_CLOSURE_CTS_SIZE(save_Scav); count++) { + STKO_DO_EVACUATE(count); + } + + /* Now evacuate the updatees in the update stack */ + while(sub > 0) { + P_ subptr; + + STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE)); + subptr = GRAB_SuB(STKO_CLOSURE_ADDR(save_Scav,sub)); + sub = STKO_CLOSURE_OFFSET(save_Scav, subptr); + } + Scav = save_Scav; +#else + /* Evacuate the link */ + DO_EVACUATE(Scav, STKO_LINK_LOCN); + + /* Evacuate the locations in the A stack */ + for (count = STKO_SpA_OFFSET(Scav); count <= STKO_CLOSURE_CTS_SIZE(Scav); count++) { + STKO_DO_EVACUATE(count); + } + + /* Now evacuate the updatees in the update stack */ + while(sub > 0) { + P_ subptr; + + STKO_DO_EVACUATE(sub + BREL(UF_UPDATEE)); + subptr = GRAB_SuB(STKO_CLOSURE_ADDR(Scav,sub)); + sub = STKO_CLOSURE_OFFSET(Scav, subptr); + } +#endif + PROFILE_CLOSURE(Scav, STKO_CLOSURE_SIZE(Scav)) + NEXT_Scav(STKO_CLOSURE_SIZE(Scav)); + return; +} + +#ifdef PAR + +void +_Scavenge_FetchMe(STG_NO_ARGS) +{ + DEBUG_SCAV(2,0); + PROFILE_CLOSURE(Scav,2); + NEXT_Scav(2); + return; +} + +void +_Scavenge_BF(STG_NO_ARGS) +{ +#if defined(GCgn) + P_ save_Scav; +#endif + + DEBUG_SCAV_BF; + +#if defined(GCgn) + /* No old generation roots should be created for mutable */ + /* pointer fields as they will be explicitly collected */ + /* Ensure this by pointing Scav at the new generation */ + save_Scav = Scav; + Scav = OldGen + 1; + + DO_EVACUATE(save_Scav, BF_LINK_LOCN); + DO_EVACUATE(save_Scav, BF_NODE_LOCN); + Scav = save_Scav; +#else + DO_EVACUATE(Scav, BF_LINK_LOCN); + DO_EVACUATE(Scav, BF_NODE_LOCN); +#endif + + PROFILE_CLOSURE(Scav, BF_CLOSURE_SIZE(dummy)) + NEXT_Scav(BF_CLOSURE_SIZE(dummy)); + return; +} + +#endif /* PAR */ +#endif /* CONCURRENT */ + +#if defined(GCgn) + +/* Recently allocated old roots for promoted objects refernecing + the new generation will be scavenged -- Just move to the next +*/ + +void +_Scavenge_OldRoot(STG_NO_ARGS) +{ + DEBUG_SCAV_OLDROOT(MIN_UPD_SIZE); /* dodgy size (WDP 95/07) */ + NEXT_Scav(MIN_UPD_SIZE); + return; +} + +P_ +_Evacuate_OldRoot(evac) +P_ evac; +{ + fprintf(stderr,"Called _Evacuate_OldRoot: Closure %lx Info %lx\nShould never occur!\n", + (W_) evac, (W_) INFO_PTR(evac)); + abort(); +} + +#endif /* GCgn */ + +void +_Scavenge_Forward_Ref(STG_NO_ARGS) +{ + fprintf(stderr,"Called _Scavenge_Forward_Ref: Closure %lx Info %lx\nShould never occur!\n", + (W_) Scav, (W_) INFO_PTR(Scav)); + abort(); +} + + +#endif /* _INFO_COPYING */ + +\end{code} diff --git a/ghc/runtime/storage/SMstacks.lc b/ghc/runtime/storage/SMstacks.lc new file mode 100644 index 0000000000..dc7452b027 --- /dev/null +++ b/ghc/runtime/storage/SMstacks.lc @@ -0,0 +1,57 @@ +\section[SMstacks.lc]{Stack allocation (sequential)} + +Routine that allocates the A and B stack (sequential only). + +\begin{code} +#ifndef PAR +# define NULL_REG_MAP +# include "SMinternal.h" + +stackData stackInfo; + +P_ stks_space = 0; + +#ifdef CONCURRENT +EXTDATA_RO(StkO_static_info); +P_ MainStkO; +#endif + +I_ +initStacks(sm) +smInfo *sm; +{ + /* + * Allocate them if they don't exist. One space does for both stacks, since they + * grow towards each other + */ + if (stks_space == 0) { +#ifdef CONCURRENT + MainStkO = (P_) xmalloc((STKO_HS + SM_word_stk_size) * sizeof(W_)); + stks_space = MainStkO + STKO_HS; + SET_STKO_HDR(MainStkO, StkO_static_info, CC_SUBSUMED); + STKO_SIZE(MainStkO) = SM_word_stk_size + STKO_VHS; + STKO_LINK(MainStkO) = Nil_closure; + STKO_RETURN(MainStkO) = NULL; +#else + stks_space = (P_) xmalloc(SM_word_stk_size * sizeof(W_)); +#endif + } +# if STACK_CHECK_BY_PAGE_FAULT + unmapMiddleStackPage((char *) stks_space, SM_word_stk_size * sizeof(W_)); +# endif + + /* Initialise Stack Info and pointers */ + stackInfo.botA = STK_A_FRAME_BASE(stks_space, SM_word_stk_size); + stackInfo.botB = STK_B_FRAME_BASE(stks_space, SM_word_stk_size); + + MAIN_SuA = MAIN_SpA = stackInfo.botA + AREL(1); + MAIN_SuB = MAIN_SpB = stackInfo.botB + BREL(1); + + if (SM_trace) + fprintf(stderr, "STACK init: botA, spa: 0x%lx, 0x%lx\n botB, spb: 0x%lx, 0x%lx\n", + (W_) stackInfo.botA, (W_) MAIN_SpA, (W_) stackInfo.botB, (W_) MAIN_SpB); + + return 0; +} +#endif /* not parallel */ +\end{code} diff --git a/ghc/runtime/storage/SMstatic.lc b/ghc/runtime/storage/SMstatic.lc new file mode 100644 index 0000000000..2f953f135a --- /dev/null +++ b/ghc/runtime/storage/SMstatic.lc @@ -0,0 +1,322 @@ +*************************************************************************** + + STATIC closures -- INTLIKE and CHARLIKE stuff. + +*************************************************************************** + +@CZh_entry@, @CZh_static_info@, @IZh_entry@ and @IZh_static_info@ +are built by the compiler from {\tr uTys.hs}. + +\begin{code} +#define NULL_REG_MAP +#include "SMinternal.h" + +EXTDATA_RO(CZh_static_info); + +#define __CHARLIKE_CLOSURE(n) (CHARLIKE_closures+((n)*(CHARLIKE_HS+1))) +#define __INTLIKE_CLOSURE(n) (INTLIKE_closures_def+(((n)-MIN_INTLIKE)*(INTLIKE_HS+1))) + +#define CHARLIKE_HDR(n) SET_STATIC_FIXED_HDR(__CHARLIKE_CLOSURE(n),CZh_static_info,CC_DONTZuCARE), (W_) n + +#define INTLIKE_HDR(n) SET_STATIC_FIXED_HDR(__INTLIKE_CLOSURE(n),IZh_static_info,CC_DONTZuCARE), (W_) n + +const W_ CHARLIKE_closures[] = { + CHARLIKE_HDR(0), + CHARLIKE_HDR(1), + CHARLIKE_HDR(2), + CHARLIKE_HDR(3), + CHARLIKE_HDR(4), + CHARLIKE_HDR(5), + CHARLIKE_HDR(6), + CHARLIKE_HDR(7), + CHARLIKE_HDR(8), + CHARLIKE_HDR(9), + CHARLIKE_HDR(10), + CHARLIKE_HDR(11), + CHARLIKE_HDR(12), + CHARLIKE_HDR(13), + CHARLIKE_HDR(14), + CHARLIKE_HDR(15), + CHARLIKE_HDR(16), + CHARLIKE_HDR(17), + CHARLIKE_HDR(18), + CHARLIKE_HDR(19), + CHARLIKE_HDR(20), + CHARLIKE_HDR(21), + CHARLIKE_HDR(22), + CHARLIKE_HDR(23), + CHARLIKE_HDR(24), + CHARLIKE_HDR(25), + CHARLIKE_HDR(26), + CHARLIKE_HDR(27), + CHARLIKE_HDR(28), + CHARLIKE_HDR(29), + CHARLIKE_HDR(30), + CHARLIKE_HDR(31), + CHARLIKE_HDR(32), + CHARLIKE_HDR(33), + CHARLIKE_HDR(34), + CHARLIKE_HDR(35), + CHARLIKE_HDR(36), + CHARLIKE_HDR(37), + CHARLIKE_HDR(38), + CHARLIKE_HDR(39), + CHARLIKE_HDR(40), + CHARLIKE_HDR(41), + CHARLIKE_HDR(42), + CHARLIKE_HDR(43), + CHARLIKE_HDR(44), + CHARLIKE_HDR(45), + CHARLIKE_HDR(46), + CHARLIKE_HDR(47), + CHARLIKE_HDR(48), + CHARLIKE_HDR(49), + CHARLIKE_HDR(50), + CHARLIKE_HDR(51), + CHARLIKE_HDR(52), + CHARLIKE_HDR(53), + CHARLIKE_HDR(54), + CHARLIKE_HDR(55), + CHARLIKE_HDR(56), + CHARLIKE_HDR(57), + CHARLIKE_HDR(58), + CHARLIKE_HDR(59), + CHARLIKE_HDR(60), + CHARLIKE_HDR(61), + CHARLIKE_HDR(62), + CHARLIKE_HDR(63), + CHARLIKE_HDR(64), + CHARLIKE_HDR(65), + CHARLIKE_HDR(66), + CHARLIKE_HDR(67), + CHARLIKE_HDR(68), + CHARLIKE_HDR(69), + CHARLIKE_HDR(70), + CHARLIKE_HDR(71), + CHARLIKE_HDR(72), + CHARLIKE_HDR(73), + CHARLIKE_HDR(74), + CHARLIKE_HDR(75), + CHARLIKE_HDR(76), + CHARLIKE_HDR(77), + CHARLIKE_HDR(78), + CHARLIKE_HDR(79), + CHARLIKE_HDR(80), + CHARLIKE_HDR(81), + CHARLIKE_HDR(82), + CHARLIKE_HDR(83), + CHARLIKE_HDR(84), + CHARLIKE_HDR(85), + CHARLIKE_HDR(86), + CHARLIKE_HDR(87), + CHARLIKE_HDR(88), + CHARLIKE_HDR(89), + CHARLIKE_HDR(90), + CHARLIKE_HDR(91), + CHARLIKE_HDR(92), + CHARLIKE_HDR(93), + CHARLIKE_HDR(94), + CHARLIKE_HDR(95), + CHARLIKE_HDR(96), + CHARLIKE_HDR(97), + CHARLIKE_HDR(98), + CHARLIKE_HDR(99), + CHARLIKE_HDR(100), + CHARLIKE_HDR(101), + CHARLIKE_HDR(102), + CHARLIKE_HDR(103), + CHARLIKE_HDR(104), + CHARLIKE_HDR(105), + CHARLIKE_HDR(106), + CHARLIKE_HDR(107), + CHARLIKE_HDR(108), + CHARLIKE_HDR(109), + CHARLIKE_HDR(110), + CHARLIKE_HDR(111), + CHARLIKE_HDR(112), + CHARLIKE_HDR(113), + CHARLIKE_HDR(114), + CHARLIKE_HDR(115), + CHARLIKE_HDR(116), + CHARLIKE_HDR(117), + CHARLIKE_HDR(118), + CHARLIKE_HDR(119), + CHARLIKE_HDR(120), + CHARLIKE_HDR(121), + CHARLIKE_HDR(122), + CHARLIKE_HDR(123), + CHARLIKE_HDR(124), + CHARLIKE_HDR(125), + CHARLIKE_HDR(126), + CHARLIKE_HDR(127), + CHARLIKE_HDR(128), + CHARLIKE_HDR(129), + CHARLIKE_HDR(130), + CHARLIKE_HDR(131), + CHARLIKE_HDR(132), + CHARLIKE_HDR(133), + CHARLIKE_HDR(134), + CHARLIKE_HDR(135), + CHARLIKE_HDR(136), + CHARLIKE_HDR(137), + CHARLIKE_HDR(138), + CHARLIKE_HDR(139), + CHARLIKE_HDR(140), + CHARLIKE_HDR(141), + CHARLIKE_HDR(142), + CHARLIKE_HDR(143), + CHARLIKE_HDR(144), + CHARLIKE_HDR(145), + CHARLIKE_HDR(146), + CHARLIKE_HDR(147), + CHARLIKE_HDR(148), + CHARLIKE_HDR(149), + CHARLIKE_HDR(150), + CHARLIKE_HDR(151), + CHARLIKE_HDR(152), + CHARLIKE_HDR(153), + CHARLIKE_HDR(154), + CHARLIKE_HDR(155), + CHARLIKE_HDR(156), + CHARLIKE_HDR(157), + CHARLIKE_HDR(158), + CHARLIKE_HDR(159), + CHARLIKE_HDR(160), + CHARLIKE_HDR(161), + CHARLIKE_HDR(162), + CHARLIKE_HDR(163), + CHARLIKE_HDR(164), + CHARLIKE_HDR(165), + CHARLIKE_HDR(166), + CHARLIKE_HDR(167), + CHARLIKE_HDR(168), + CHARLIKE_HDR(169), + CHARLIKE_HDR(170), + CHARLIKE_HDR(171), + CHARLIKE_HDR(172), + CHARLIKE_HDR(173), + CHARLIKE_HDR(174), + CHARLIKE_HDR(175), + CHARLIKE_HDR(176), + CHARLIKE_HDR(177), + CHARLIKE_HDR(178), + CHARLIKE_HDR(179), + CHARLIKE_HDR(180), + CHARLIKE_HDR(181), + CHARLIKE_HDR(182), + CHARLIKE_HDR(183), + CHARLIKE_HDR(184), + CHARLIKE_HDR(185), + CHARLIKE_HDR(186), + CHARLIKE_HDR(187), + CHARLIKE_HDR(188), + CHARLIKE_HDR(189), + CHARLIKE_HDR(190), + CHARLIKE_HDR(191), + CHARLIKE_HDR(192), + CHARLIKE_HDR(193), + CHARLIKE_HDR(194), + CHARLIKE_HDR(195), + CHARLIKE_HDR(196), + CHARLIKE_HDR(197), + CHARLIKE_HDR(198), + CHARLIKE_HDR(199), + CHARLIKE_HDR(200), + CHARLIKE_HDR(201), + CHARLIKE_HDR(202), + CHARLIKE_HDR(203), + CHARLIKE_HDR(204), + CHARLIKE_HDR(205), + CHARLIKE_HDR(206), + CHARLIKE_HDR(207), + CHARLIKE_HDR(208), + CHARLIKE_HDR(209), + CHARLIKE_HDR(210), + CHARLIKE_HDR(211), + CHARLIKE_HDR(212), + CHARLIKE_HDR(213), + CHARLIKE_HDR(214), + CHARLIKE_HDR(215), + CHARLIKE_HDR(216), + CHARLIKE_HDR(217), + CHARLIKE_HDR(218), + CHARLIKE_HDR(219), + CHARLIKE_HDR(220), + CHARLIKE_HDR(221), + CHARLIKE_HDR(222), + CHARLIKE_HDR(223), + CHARLIKE_HDR(224), + CHARLIKE_HDR(225), + CHARLIKE_HDR(226), + CHARLIKE_HDR(227), + CHARLIKE_HDR(228), + CHARLIKE_HDR(229), + CHARLIKE_HDR(230), + CHARLIKE_HDR(231), + CHARLIKE_HDR(232), + CHARLIKE_HDR(233), + CHARLIKE_HDR(234), + CHARLIKE_HDR(235), + CHARLIKE_HDR(236), + CHARLIKE_HDR(237), + CHARLIKE_HDR(238), + CHARLIKE_HDR(239), + CHARLIKE_HDR(240), + CHARLIKE_HDR(241), + CHARLIKE_HDR(242), + CHARLIKE_HDR(243), + CHARLIKE_HDR(244), + CHARLIKE_HDR(245), + CHARLIKE_HDR(246), + CHARLIKE_HDR(247), + CHARLIKE_HDR(248), + CHARLIKE_HDR(249), + CHARLIKE_HDR(250), + CHARLIKE_HDR(251), + CHARLIKE_HDR(252), + CHARLIKE_HDR(253), + CHARLIKE_HDR(254), + CHARLIKE_HDR(255) +}; + +EXTDATA_RO(IZh_static_info); + +static const W_ INTLIKE_closures_def[] = { + INTLIKE_HDR(-16), /* MIN_INTLIKE == -16 */ + INTLIKE_HDR(-15), + INTLIKE_HDR(-14), + INTLIKE_HDR(-13), + INTLIKE_HDR(-12), + INTLIKE_HDR(-11), + INTLIKE_HDR(-10), + INTLIKE_HDR(-9), + INTLIKE_HDR(-8), + INTLIKE_HDR(-7), + INTLIKE_HDR(-6), + INTLIKE_HDR(-5), + INTLIKE_HDR(-4), + INTLIKE_HDR(-3), + INTLIKE_HDR(-2), + INTLIKE_HDR(-1), + INTLIKE_HDR(0), + INTLIKE_HDR(1), + INTLIKE_HDR(2), + INTLIKE_HDR(3), + INTLIKE_HDR(4), + INTLIKE_HDR(5), + INTLIKE_HDR(6), + INTLIKE_HDR(7), + INTLIKE_HDR(8), + INTLIKE_HDR(9), + INTLIKE_HDR(10), + INTLIKE_HDR(11), + INTLIKE_HDR(12), + INTLIKE_HDR(13), + INTLIKE_HDR(14), + INTLIKE_HDR(15), + INTLIKE_HDR(16) /* MAX_INTLIKE == 16 */ +}; + +P_ INTLIKE_closures = (P_) __INTLIKE_CLOSURE(0); + +\end{code} diff --git a/ghc/runtime/storage/SMstats.lc b/ghc/runtime/storage/SMstats.lc new file mode 100644 index 0000000000..3f6dfc3d60 --- /dev/null +++ b/ghc/runtime/storage/SMstats.lc @@ -0,0 +1,468 @@ +********************************************************************* + + Stuff for printing out GC statistics + +usertime() -- The current user time in seconds +elapsedtime() -- The current elapsed time in seconds + +stat_init +stat_startGC +stat_endGC +stat_exit + +********************************************************************* + +\begin{code} +#ifdef hpux_TARGET_OS +#define _INCLUDE_HPUX_SOURCE +#endif + +#define NULL_REG_MAP +#include "SMinternal.h" +#include "RednCounts.h" + +#ifdef HAVE_SYS_TYPES_H +#include <sys/types.h> +#endif + +#ifdef HAVE_UNISTD_H +#include <unistd.h> +#endif + +#ifdef HAVE_SYS_TIMES_H +#include <sys/times.h> +#endif + +#ifdef HAVE_SYS_TIME_H +#include <sys/time.h> +#endif + +#if defined(HAVE_SYS_RESOURCE_H) && ! irix_TARGET_OS +#include <sys/resource.h> +#endif + +#ifdef HAVE_SYS_TIMEB_H +#include <sys/timeb.h> +#endif + +#ifdef hpux_TARGET_OS +#include <sys/syscall.h> +#define getrusage(a, b) syscall(SYS_GETRUSAGE, a, b) +#define HAVE_GETRUSAGE +#endif + +static StgDouble GC_start_time, GC_tot_time = 0; /* User GC Time */ +static StgDouble GCe_start_time, GCe_tot_time = 0; /* Elapsed GC time */ + +#if defined(GCap) || defined(GCgn) +static StgDouble GC_min_time = 0; +static StgDouble GCe_min_time = 0; + +static I_ GC_min_no = 0; +static I_ GC_min_since_maj = 0; +static I_ GC_live_maj = 0; /* Heap live at last major collection */ +static I_ GC_alloc_since_maj = 0; /* Heap alloc since collection major */ +#endif + +static I_ GC_maj_no = 0; +static ullong GC_tot_alloc = 0; /* Total heap allocated -- 64 bits? */ + +static I_ GC_start_faults = 0, GC_end_faults = 0; + +char * +#ifdef __STDC__ +ullong_format_string(ullong x, char *s, rtsBool with_commas) +#else +ullong_format_string(x, s, with_commas) + ullong x; + char *s; + rtsBool with_commas; +#endif +{ + if (x < (ullong)1000) + sprintf(s, "%ld", (I_)x); + else if (x < (ullong)1000000) + sprintf(s, (with_commas) ? "%ld,%3.3ld" : "%ld%3.3ld", + (I_)((x)/(ullong)1000), + (I_)((x)%(ullong)1000)); + else if (x < (ullong)1000000000) + sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld", + (I_)((x)/(ullong)1000000), + (I_)((x)/(ullong)1000%(ullong)1000), + (I_)((x)%(ullong)1000)); + else + sprintf(s, (with_commas) ? "%ld,%3.3ld,%3.3ld,%3.3ld" : "%ld%3.3ld%3.3ld%3.3ld", + (I_)((x)/(ullong)1000000000), + (I_)((x)/(ullong)1000000%(ullong)1000), + (I_)((x)/(ullong)1000%(ullong)1000), + (I_)((x)%(ullong)1000)); + return s; +} + +/* "constants" for "usertime" and "elapsedtime" */ + +static StgDouble ElapsedTimeStart = 0.0; /* setup when beginning things */ +static StgDouble TicksPerSecond = 0.0; /* ditto */ + +/* usertime() -- The current user time in seconds */ + +StgDouble +usertime() +{ +#if ! (defined(HAVE_GETRUSAGE) || defined(HAVE_TIMES)) + /* We will #ifdef around the fprintf for machines + we *know* are unsupported. (WDP 94/05) + */ + fprintf(stderr, "NOTE: `usertime' does nothing!\n"); + return 0.0; + +#else /* not stumped */ + +/* "times" is the more standard, but we prefer "getrusage" + (because we are old worn-out BSD hackers) +*/ +# if defined(HAVE_GETRUSAGE) && ! irix_TARGET_OS + struct rusage t; + + getrusage(RUSAGE_SELF, &t); + return(t.ru_utime.tv_sec + 1e-6*t.ru_utime.tv_usec); + +# else /* HAVE_TIMES */ + struct tms t; + + times(&t); + return(((StgDouble)(t.tms_utime))/TicksPerSecond); + +# endif /* HAVE_TIMES */ +#endif /* not stumped */ +} + + +/* elapsedtime() -- The current elapsed time in seconds */ + +StgDouble +elapsedtime() +{ +#if ! (defined(HAVE_TIMES) || defined(HAVE_FTIME)) + /* We will #ifdef around the fprintf for machines + we *know* are unsupported. (WDP 94/05) + */ + fprintf(stderr, "NOTE: `elapsedtime' does nothing!\n"); + return 0.0; + +#else /* not stumped */ + +/* "ftime" may be nicer, but "times" is more standard; + but, on a Sun, if you do not get the SysV one, you are *hosed*... + */ + +# if defined(HAVE_TIMES) && ! sunos4_TARGET_OS + struct tms t; + + return (((StgDouble) times(&t))/TicksPerSecond - ElapsedTimeStart); + +# else /* HAVE_FTIME */ + struct timeb t; + + ftime(&t); + return t.time + 1e-3*t.millitm - ElapsedTimeStart; + +# endif /* HAVE_FTIME */ +#endif /* not stumped */ +} + +void +start_time(STG_NO_ARGS) +{ + long ticks; + + /* Determine TicksPerSecond ... */ +#ifdef HAVE_SYSCONF + ticks = sysconf(_SC_CLK_TCK); + if ( ticks == -1 ) { + fprintf(stderr, "stat_init: bad call to 'sysconf'!\n"); + EXIT(EXIT_FAILURE); + } + TicksPerSecond = (StgDouble) ticks; + +#else /* no "sysconf"; had better guess */ +# ifdef HZ + TicksPerSecond = (StgDouble) (HZ); + +# else /* had better guess wildly */ + /* We will #ifdef around the fprintf for machines + we *know* are unsupported. (WDP 94/05) + */ + fprintf(stderr, "NOTE: Guessing `TicksPerSecond = 60'!\n"); + TicksPerSecond = 60.0; + return; +# endif +#endif + ElapsedTimeStart = elapsedtime(); +} + +static StgDouble InitUserTime = 0.0; /* user time taken for initialization */ +static StgDouble InitElapsedTime = 0.0; /* elapsed time taken for initialization */ + +void end_init(STG_NO_ARGS) +{ + InitUserTime = usertime(); + InitElapsedTime = elapsedtime(); +} + +static I_ +pagefaults(STG_NO_ARGS) +{ +#if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS + return 0; +#else + struct rusage t; + + getrusage(RUSAGE_SELF, &t); + return(t.ru_majflt); +#endif +} + +/* Called at the beginning of execution of the program */ +/* Writes the command line and inits stats header */ + +void stat_init(collector, comment1, comment2) +char *collector, *comment1, *comment2; +{ + if (SM_statsfile != NULL) { + char temp[BIG_STRING_LEN]; + ullong_format_string( (ullong)SM_word_heap_size*sizeof(W_), temp, rtsTrue/*commas*/); + fprintf(SM_statsfile, "\nCollector: %s HeapSize: %s (bytes)\n\n", collector, temp); + if (SM_stats_verbose) { +#if !defined(HAVE_GETRUSAGE) || irix_TARGET_OS + fprintf(SM_statsfile, "NOTE: `pagefaults' does nothing!\n"); +#endif + fprintf(SM_statsfile, +/*######## ####### ####### ##.# ##.## ##.## ####.## ####.## #### ####*/ + " Alloc Collect Live Resid GC GC TOT TOT Page Flts %s\n", + comment1); + fprintf(SM_statsfile, + " bytes bytes bytes ency user elap user elap GC MUT %s\n", + comment2); + } + +#if defined(GCap) || defined(GCgn) + else { + fprintf(SM_statsfile, +/*######## ####### ##.# ####### ##.# ### ##.## ##.## ##.## ##.## ####.## ####.## #### ####*/ + " Alloc Promote Promo Live Resid Minor Minor Minor Major Major TOT TOT Page Flts\n"); + fprintf(SM_statsfile, + " bytes bytes ted bytes ency No user elap user elap user elap MUT Major\n"); + } +#endif /* generational */ + + fflush(SM_statsfile); + } +} + + +/* Called at the beginning of each GC */ +static I_ rub_bell = 0; + +void +stat_startGC(alloc) + I_ alloc; +{ +#if defined(GCap) || defined(GCgn) + I_ bell = alloc == 0 ? SM_ring_bell : 0; +#else /* ! generational */ + I_ bell = SM_ring_bell; +#endif /* ! generational */ + + if (bell) { + if (bell > 1) { + fprintf(stderr, " GC "); + rub_bell = 1; + } else { + fprintf(stderr, "\007"); + } + } + + if (SM_statsfile != NULL) { + GC_start_time = usertime(); + GCe_start_time = elapsedtime(); + +#if defined(GCap) || defined(GCgn) + if (SM_stats_verbose || alloc == 0) { + GC_start_faults = pagefaults(); + } +#else /* ! generational */ + if (SM_stats_verbose) { + GC_start_faults = pagefaults(); + } +#endif /* ! generational */ + + } +} + + +/* Called at the end of each GC */ + +void +stat_endGC(alloc, collect, live, comment) + I_ alloc, collect, live; + char *comment; +{ + if (SM_statsfile != NULL) { + StgDouble time = usertime(); + StgDouble etime = elapsedtime(); + + if (SM_stats_verbose){ + I_ faults = pagefaults(); + + fprintf(SM_statsfile, "%8ld %7ld %7ld %5.1f%%", + alloc*sizeof(W_), collect*sizeof(W_), live*sizeof(W_), collect == 0 ? 0.0 : (live / (StgFloat) collect * 100)); + fprintf(SM_statsfile, " %5.2f %5.2f %7.2f %7.2f %4ld %4ld %s\n", + (time-GC_start_time), + (etime-GCe_start_time), + time, + etime, + faults - GC_start_faults, + GC_start_faults - GC_end_faults, + comment); + + GC_end_faults = faults; + fflush(SM_statsfile); + } + +#if defined(GCap) || defined(GCgn) + else if(alloc == 0 && collect != 0) { + I_ faults = pagefaults(); + + fprintf(SM_statsfile, "%8ld %7ld %5.1f%% %7ld %5.1f%%", + GC_alloc_since_maj*sizeof(W_), (collect - GC_live_maj)*sizeof(W_), + (collect - GC_live_maj) / (StgFloat) GC_alloc_since_maj * 100, + live*sizeof(W_), live / (StgFloat) SM_word_heap_size * 100); + fprintf(SM_statsfile, " %3ld %5.2f %5.2f %5.2f %5.2f %7.2f %7.2f %4ld %4ld\n", + GC_min_since_maj, GC_min_time, GCe_min_time, + (time-GC_start_time), + (etime-GCe_start_time), + time, + etime, + faults - GC_start_faults, + GC_start_faults - GC_end_faults + ); + + GC_end_faults = faults; + fflush(SM_statsfile); + } +#endif /* generational */ + +#if defined(GCap) || defined(GCgn) + if (alloc == 0 && collect != 0) { + GC_maj_no++; + GC_live_maj = live; + GC_min_no += GC_min_since_maj; + GC_min_since_maj = 0; + GC_tot_alloc += (ullong) GC_alloc_since_maj; + GC_alloc_since_maj = 0; + GC_tot_time += time-GC_start_time + GC_min_time; + GC_min_time = 0; + GCe_tot_time += etime-GCe_start_time + GCe_min_time; + GCe_min_time = 0; + } else { + GC_min_since_maj++; + GC_alloc_since_maj += alloc; + GC_min_time += time-GC_start_time; + GCe_min_time += etime-GCe_start_time; + } +#else /* ! generational */ + GC_maj_no++; + GC_tot_alloc += (ullong) alloc; + GC_tot_time += time-GC_start_time; + GCe_tot_time += etime-GCe_start_time; +#endif /* ! generational */ + + } + + if (rub_bell) { + fprintf(stderr, "\b\b\b \b\b\b"); + rub_bell = 0; + } +} + + +/* Called at the end of execution -- to print a summary of statistics */ + +void +stat_exit(alloc) + I_ alloc; +{ + if (SM_statsfile != NULL){ + char temp[BIG_STRING_LEN]; + StgDouble time = usertime(); + StgDouble etime = elapsedtime(); + + if (SM_stats_verbose) { + fprintf(SM_statsfile, "%8ld\n\n", alloc*sizeof(W_)); + } + +#if defined(GCap) || defined (GCgn) + else { + fprintf(SM_statsfile, "%8ld %7.7s %6.6s %7.7s %6.6s", + (GC_alloc_since_maj + alloc)*sizeof(W_), "", "", "", ""); + fprintf(SM_statsfile, " %3ld %5.2f %5.2f\n\n", + GC_min_since_maj, GC_min_time, GCe_min_time); + } + GC_min_no += GC_min_since_maj; + GC_tot_time += GC_min_time; + GCe_tot_time += GCe_min_time; + GC_tot_alloc += (ullong) (GC_alloc_since_maj + alloc); + ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/); + fprintf(SM_statsfile, "%11s bytes allocated in the heap\n", temp); + if ( ResidencySamples > 0 ) { + ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/); + fprintf(SM_statsfile, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n", + temp, + MaxResidency / (StgFloat) SM_word_heap_size * 100, + ResidencySamples); + } + fprintf(SM_statsfile, "%11ld garbage collections performed (%ld major, %ld minor)\n\n", + GC_maj_no + GC_min_no, GC_maj_no, GC_min_no); + +#else /* ! generational */ + + GC_tot_alloc += (ullong) alloc; + ullong_format_string(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/); + fprintf(SM_statsfile, "%11s bytes allocated in the heap\n", temp); + if ( ResidencySamples > 0 ) { + ullong_format_string(MaxResidency*sizeof(W_), temp, rtsTrue/*commas*/); + fprintf(SM_statsfile, "%11s bytes maximum residency (%.1f%%, %ld sample(s))\n", + temp, + MaxResidency / (StgFloat) SM_word_heap_size * 100, + ResidencySamples); + } + fprintf(SM_statsfile, "%11ld garbage collections performed\n\n", GC_maj_no); + +#endif /* ! generational */ + + fprintf(SM_statsfile, " INIT time %6.2fs (%6.2fs elapsed)\n", + InitUserTime, InitElapsedTime); + fprintf(SM_statsfile, " MUT time %6.2fs (%6.2fs elapsed)\n", + time - GC_tot_time - InitUserTime, + etime - GCe_tot_time - InitElapsedTime); + fprintf(SM_statsfile, " GC time %6.2fs (%6.2fs elapsed)\n", + GC_tot_time, GCe_tot_time); + fprintf(SM_statsfile, " Total time %6.2fs (%6.2fs elapsed)\n\n", + time, etime); + + fprintf(SM_statsfile, " %%GC time %5.1f%% (%.1f%% elapsed)\n\n", + GC_tot_time*100./time, GCe_tot_time*100./etime); + + ullong_format_string((ullong)(GC_tot_alloc*sizeof(W_)/(time - GC_tot_time)), temp, rtsTrue/*commas*/); + fprintf(SM_statsfile, " Alloc rate %s bytes per MUT second\n\n", temp); + + fprintf(SM_statsfile, " Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n", + (time - GC_tot_time - InitUserTime) * 100. / time, + (time - GC_tot_time - InitUserTime) * 100. / etime); + fflush(SM_statsfile); + fclose(SM_statsfile); + } +} + +\end{code} diff --git a/ghc/runtime/storage/mprotect.lc b/ghc/runtime/storage/mprotect.lc new file mode 100644 index 0000000000..8c50a6ee5a --- /dev/null +++ b/ghc/runtime/storage/mprotect.lc @@ -0,0 +1,78 @@ +% +% (c) The AQUA Project, Glasgow University, 1995 +% +%************************************************************************ +%* * +\section[mprotect.lc]{Memory Protection} +%* * +%************************************************************************ + +Is @mprotect@ POSIX now? + +\begin{code} + +#if STACK_CHECK_BY_PAGE_FAULT + +/* #define STK_CHK_DEBUG */ + +#include "rtsdefs.h" + +# ifdef HAVE_SYS_TYPES_H +# include <sys/types.h> +# endif + +# ifdef HAVE_SYS_MMAN_H +# include <sys/mman.h> +# endif + +# if defined(_SC_PAGE_SIZE) && !defined(_SC_PAGESIZE) + /* Death to HP-UX. What are standards for, anyway??? */ +# define _SC_PAGESIZE _SC_PAGE_SIZE +# endif + +# if defined(_SC_PAGESIZE) +# define GETPAGESIZE() sysconf(_SC_PAGESIZE) +# else +# if defined(HAVE_GETPAGESIZE) +# define GETPAGESIZE() getpagesize() +# else +# error getpagesize +# endif +# endif + +#if defined(sunos4_TARGET_OS) +extern int getpagesize PROTO((void)); +extern int mprotect PROTO((caddr_t, size_t, int)); +#endif + +void +unmapMiddleStackPage(addr_, size) +char * /*caddr_t*/ addr_; +int size; +{ + int pagesize = GETPAGESIZE(); + caddr_t addr = addr_; + caddr_t middle = (caddr_t) (((W_) (addr + size / 2)) / pagesize * pagesize); + +# ifdef STK_CHK_DEBUG + fprintf(stderr, "pagesize: %x\nstack start: %08lx\nstack size: %08lx\nstack middle: %08lx\n", + pagesize, addr, size, middle); +# endif + + if (middle < addr || middle + pagesize > addr + size) { + fprintf(stderr, "Stack too small; stack overflow trap disabled.\n"); + return; + } + if (mprotect(middle, pagesize, PROT_NONE) == -1) { + perror("mprotect"); + exit(1); + } + if (install_segv_handler()) { + fprintf(stderr, "Can't install SIGSEGV handler for stack overflow check.\n"); + EXIT(EXIT_FAILURE); + } +} + +#endif /* STACK_CHECK_BY_PAGE_FAULT */ + +\end{code} |