/* -----------------------------------------------------------------------------
*
- * (c) The GHC Team, 1998-2004
+ * (c) The GHC Team, 1998-2006
*
* Storage manager front end
*
+ * Documentation on the architecture of the Storage Manager can be
+ * found in the online commentary:
+ *
+ * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage
+ *
* ---------------------------------------------------------------------------*/
#include "PosixSource.h"
return;
}
+ initMBlocks();
+
/* Sanity check to make sure the LOOKS_LIKE_ macros appear to be
* doing something reasonable.
*/
#if defined(THREADED_RTS)
closeMutex(&sm_mutex);
closeMutex(&atomic_modify_mutvar_mutex);
+ stgFree(nurseries);
#endif
}
nurseries[i].n_blocks = RtsFlags.GcFlags.minAllocAreaSize;
nurseries[i].old_blocks = NULL;
nurseries[i].n_old_blocks = 0;
- /* hp, hpLim, hp_bd, to_space etc. aren't used in the nursery */
}
assignNurseriesToCapabilities();
}
nat req_blocks = (lnat)BLOCK_ROUND_UP(n*sizeof(W_)) / BLOCK_SIZE;
bd = allocGroup(req_blocks);
dbl_link_onto(bd, &g0s0->large_objects);
- g0s0->n_large_blocks += req_blocks;
+ g0s0->n_large_blocks += bd->blocks; // might be larger than req_blocks
bd->gen_no = 0;
bd->step = g0s0;
bd->flags = BF_LARGE;
ACQUIRE_SM_LOCK;
bd = allocGroup(req_blocks);
dbl_link_onto(bd, &g0s0->large_objects);
- g0s0->n_large_blocks += req_blocks;
+ g0s0->n_large_blocks += bd->blocks; // might be larger than req_blocks
bd->gen_no = 0;
bd->step = g0s0;
bd->flags = BF_LARGE;
if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) {
pinned_object_block = bd = allocBlock();
dbl_link_onto(bd, &g0s0->large_objects);
+ g0s0->n_large_blocks++;
bd->gen_no = 0;
bd->step = g0s0;
bd->flags = BF_PINNED | BF_LARGE;
step *stp;
if (RtsFlags.GcFlags.generations == 1) {
- live = (g0s0->n_blocks - 1) * BLOCK_SIZE_W +
- ((lnat)g0s0->hp_bd->free - (lnat)g0s0->hp_bd->start) / sizeof(W_);
- return live;
+ return (g0s0->n_large_blocks + g0s0->n_blocks) * BLOCK_SIZE_W;
}
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
continue;
}
stp = &generations[g].steps[s];
- live += (stp->n_large_blocks + stp->n_blocks - 1) * BLOCK_SIZE_W;
- if (stp->hp_bd != NULL) {
- live += ((lnat)stp->hp_bd->free - (lnat)stp->hp_bd->start)
- / sizeof(W_);
- }
- if (stp->scavd_hp != NULL) {
- live -= (P_)(BLOCK_ROUND_UP(stp->scavd_hp)) - stp->scavd_hp;
- }
+ live += (stp->n_large_blocks + stp->n_blocks) * BLOCK_SIZE_W;
}
}
return live;
in the page, and when the page is emptied (all objects on the page
are free) we free the page again, not forgetting to make it
non-executable.
+
+ TODO: The inability to handle objects bigger than BLOCK_SIZE_W means that
+ the linker cannot use allocateExec for loading object code files
+ on Windows. Once allocateExec can handle larger objects, the linker
+ should be modified to use allocateExec instead of VirtualAlloc.
------------------------------------------------------------------------- */
static bdescr *exec_block;
bd->gen_no -= *(StgPtr)p;
*(StgPtr)p = 0;
- // Free the block if it is empty, but not if it is the block at
- // the head of the queue.
- if (bd->gen_no == 0 && bd != exec_block) {
- debugTrace(DEBUG_gc, "free exec block %p", bd->start);
- if (bd->u.back) {
- bd->u.back->link = bd->link;
- } else {
- exec_block = bd->link;
- }
- if (bd->link) {
- bd->link->u.back = bd->u.back;
- }
- setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
- freeGroup(bd);
+ if (bd->gen_no == 0) {
+ // Free the block if it is empty, but not if it is the block at
+ // the head of the queue.
+ if (bd != exec_block) {
+ debugTrace(DEBUG_gc, "free exec block %p", bd->start);
+ dbl_link_remove(bd, &exec_block);
+ setExecutable(bd->start, bd->blocks * BLOCK_SIZE, rtsFalse);
+ freeGroup(bd);
+ } else {
+ bd->free = bd->start;
+ }
}
RELEASE_SM_LOCK
#ifdef DEBUG
-static lnat
-stepBlocks (step *stp)
+nat
+countBlocks(bdescr *bd)
{
- lnat total_blocks;
- bdescr *bd;
+ nat n;
+ for (n=0; bd != NULL; bd=bd->link) {
+ n += bd->blocks;
+ }
+ return n;
+}
- total_blocks = stp->n_blocks;
- total_blocks += stp->n_old_blocks;
- for (bd = stp->large_objects; bd; bd = bd->link) {
- total_blocks += bd->blocks;
- /* hack for megablock groups: they have an extra block or two in
- the second and subsequent megablocks where the block
- descriptors would normally go.
- */
+// (*1) Just like countBlocks, except that we adjust the count for a
+// megablock group so that it doesn't include the extra few blocks
+// that would be taken up by block descriptors in the second and
+// subsequent megablock. This is so we can tally the count with the
+// number of blocks allocated in the system, for memInventory().
+static nat
+countAllocdBlocks(bdescr *bd)
+{
+ nat n;
+ for (n=0; bd != NULL; bd=bd->link) {
+ n += bd->blocks;
+ // hack for megablock groups: see (*1) above
if (bd->blocks > BLOCKS_PER_MBLOCK) {
- total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
+ n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
* (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
}
}
- return total_blocks;
+ return n;
+}
+
+static lnat
+stepBlocks (step *stp)
+{
+ ASSERT(countBlocks(stp->blocks) == stp->n_blocks);
+ ASSERT(countBlocks(stp->large_objects) == stp->n_large_blocks);
+ return stp->n_blocks + stp->n_old_blocks +
+ countAllocdBlocks(stp->large_objects);
}
void
{
nat g, s, i;
step *stp;
- bdescr *bd;
- lnat total_blocks = 0, free_blocks = 0;
+ lnat gen_blocks[RtsFlags.GcFlags.generations];
+ lnat nursery_blocks, allocate_blocks, retainer_blocks,
+ arena_blocks, exec_blocks;
+ lnat live_blocks = 0, free_blocks = 0;
- /* count the blocks we current have */
+ // count the blocks we current have
for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ gen_blocks[g] = 0;
for (i = 0; i < n_capabilities; i++) {
- for (bd = capabilities[i].mut_lists[g]; bd != NULL; bd = bd->link) {
- total_blocks += bd->blocks;
- }
+ gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
}
- for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
- total_blocks += bd->blocks;
- }
+ gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
for (s = 0; s < generations[g].n_steps; s++) {
+#if !defined(THREADED_RTS)
+ // We put pinned object blocks in g0s0, so better count
+ // blocks there too.
if (g==0 && s==0) continue;
+#endif
stp = &generations[g].steps[s];
- total_blocks += stepBlocks(stp);
+ gen_blocks[g] += stepBlocks(stp);
}
}
+ nursery_blocks = 0;
for (i = 0; i < n_nurseries; i++) {
- total_blocks += stepBlocks(&nurseries[i]);
+ nursery_blocks += stepBlocks(&nurseries[i]);
}
-#ifdef THREADED_RTS
- // We put pinned object blocks in g0s0, so better count blocks there too.
- total_blocks += stepBlocks(g0s0);
-#endif
/* any blocks held by allocate() */
- for (bd = small_alloc_list; bd; bd = bd->link) {
- total_blocks += bd->blocks;
- }
+ allocate_blocks = countAllocdBlocks(small_alloc_list);
+ retainer_blocks = 0;
#ifdef PROFILING
if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
- total_blocks += retainerStackBlocks();
+ retainer_blocks = retainerStackBlocks();
}
#endif
// count the blocks allocated by the arena allocator
- total_blocks += arenaBlocks();
+ arena_blocks = arenaBlocks();
// count the blocks containing executable memory
- for (bd = exec_block; bd; bd = bd->link) {
- total_blocks += bd->blocks;
- }
+ exec_blocks = countAllocdBlocks(exec_block);
/* count the blocks on the free list */
free_blocks = countFreeList();
- if (total_blocks + free_blocks != mblocks_allocated *
- BLOCKS_PER_MBLOCK) {
- debugBelch("Blocks: %ld live + %ld free = %ld total (%ld around)\n",
- total_blocks, free_blocks, total_blocks + free_blocks,
- mblocks_allocated * BLOCKS_PER_MBLOCK);
+ live_blocks = 0;
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ live_blocks += gen_blocks[g];
}
+ live_blocks += nursery_blocks + allocate_blocks
+ + retainer_blocks + arena_blocks + exec_blocks;
- ASSERT(total_blocks + free_blocks == mblocks_allocated * BLOCKS_PER_MBLOCK);
+ if (live_blocks + free_blocks != mblocks_allocated * BLOCKS_PER_MBLOCK)
+ {
+ debugBelch("Memory leak detected\n");
+ for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
+ debugBelch(" gen %d blocks : %4lu\n", g, gen_blocks[g]);
+ }
+ debugBelch(" nursery : %4lu\n", nursery_blocks);
+ debugBelch(" allocate() : %4lu\n", allocate_blocks);
+ debugBelch(" retainer : %4lu\n", retainer_blocks);
+ debugBelch(" arena blocks : %4lu\n", arena_blocks);
+ debugBelch(" exec : %4lu\n", exec_blocks);
+ debugBelch(" free : %4lu\n", free_blocks);
+ debugBelch(" total : %4lu\n\n", live_blocks + free_blocks);
+ debugBelch(" in system : %4lu\n", mblocks_allocated * BLOCKS_PER_MBLOCK);
+ ASSERT(0);
+ }
}
-nat
-countBlocks(bdescr *bd)
-{
- nat n;
- for (n=0; bd != NULL; bd=bd->link) {
- n += bd->blocks;
- }
- return n;
-}
-
/* Full heap sanity check. */
void
checkSanity( void )
projects / ghc-hetmet.git / blobdiff