-static lnat
-stepBlocks (step *stp)
-{
- lnat total_blocks;
- bdescr *bd;
-
- 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.
- */
- if (bd->blocks > BLOCKS_PER_MBLOCK) {
- total_blocks -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
- * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
- }
- }
- return total_blocks;
-}
-
-void
-memInventory(void)
-{
- nat g, s, i;
- step *stp;
- bdescr *bd;
- 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
-
- 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) {
- gen_blocks[g] += bd->blocks;
- }
- }
- for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) {
- gen_blocks[g] += bd->blocks;
- }
- for (s = 0; s < generations[g].n_steps; s++) {
- if (g==0 && s==0) continue;
- stp = &generations[g].steps[s];
- gen_blocks[g] += stepBlocks(stp);
- }
- }
-
- nursery_blocks = 0;
- for (i = 0; i < n_nurseries; i++) {
- nursery_blocks += stepBlocks(&nurseries[i]);
- }
-#ifdef THREADED_RTS
- // We put pinned object blocks in g0s0, so better count blocks there too.
- gen_blocks[0] += stepBlocks(g0s0);
-#endif
-
- /* any blocks held by allocate() */
- allocate_blocks = 0;
- for (bd = small_alloc_list; bd; bd = bd->link) {
- allocate_blocks += bd->blocks;
- }
-
- retainer_blocks = 0;
-#ifdef PROFILING
- if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_RETAINER) {
- retainer_blocks = retainerStackBlocks();
- }
-#endif
-
- // count the blocks allocated by the arena allocator
- arena_blocks = arenaBlocks();
-
- // count the blocks containing executable memory
- exec_blocks = 0;
- for (bd = exec_block; bd; bd = bd->link) {
- exec_blocks += bd->blocks;
- }
-
- /* count the blocks on the free list */
- free_blocks = countFreeList();
-
- 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;
-
- 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 )
-{
- nat g, s;
-
- if (RtsFlags.GcFlags.generations == 1) {
- checkHeap(g0s0->blocks);
- checkChain(g0s0->large_objects);
- } else {
-
- for (g = 0; g < RtsFlags.GcFlags.generations; g++) {
- for (s = 0; s < generations[g].n_steps; s++) {
- if (g == 0 && s == 0) { continue; }
- ASSERT(countBlocks(generations[g].steps[s].blocks)
- == generations[g].steps[s].n_blocks);
- ASSERT(countBlocks(generations[g].steps[s].large_objects)
- == generations[g].steps[s].n_large_blocks);
- checkHeap(generations[g].steps[s].blocks);
- checkChain(generations[g].steps[s].large_objects);
- if (g > 0) {
- checkMutableList(generations[g].mut_list, g);
- }
- }
- }
-
- for (s = 0; s < n_nurseries; s++) {
- ASSERT(countBlocks(nurseries[s].blocks)
- == nurseries[s].n_blocks);
- ASSERT(countBlocks(nurseries[s].large_objects)
- == nurseries[s].n_large_blocks);
- }
-
- checkFreeListSanity();
- }
-}
-
-/* Nursery sanity check */
-void
-checkNurserySanity( step *stp )
-{
- bdescr *bd, *prev;
- nat blocks = 0;
-
- prev = NULL;
- for (bd = stp->blocks; bd != NULL; bd = bd->link) {
- ASSERT(bd->u.back == prev);
- prev = bd;
- blocks += bd->blocks;
- }
- ASSERT(blocks == stp->n_blocks);
-}
-