-// Useful for finding partially full blocks in gdb
-void findSlop(bdescr *bd);
-void findSlop(bdescr *bd)
-{
- lnat slop;
-
- for (; bd != NULL; bd = bd->link) {
- slop = (bd->blocks * BLOCK_SIZE_W) - (bd->free - bd->start);
- if (slop > (1024/sizeof(W_))) {
- debugBelch("block at %p (bdescr %p) has %ldKB slop\n",
- bd->start, bd, slop / (1024/sizeof(W_)));
- }
- }
-}
-
-nat
-countBlocks(bdescr *bd)
-{
- nat n;
- for (n=0; bd != NULL; bd=bd->link) {
- n += bd->blocks;
- }
- return n;
-}
-
-// (*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) {
- n -= (MBLOCK_SIZE / BLOCK_SIZE - BLOCKS_PER_MBLOCK)
- * (bd->blocks/(MBLOCK_SIZE/BLOCK_SIZE));
- }
- }
- 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
-memInventory(void)
-{
- nat g, s, i;
- step *stp;
- lnat gen_blocks[RtsFlags.GcFlags.generations];
- lnat nursery_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++) {
- gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]);
- }
- gen_blocks[g] += countAllocdBlocks(generations[g].mut_list);
- for (s = 0; s < generations[g].n_steps; s++) {
- 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]);
- }
-
- 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 = countAllocdBlocks(exec_block);
-
- /* 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 +
- + 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(" 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);
- }
-}
-
-
-/* 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);
-}
-