+++ /dev/null
-/* -----------------------------------------------------------------------------
- *
- * (c) The GHC Team 1998-2006
- *
- * The block allocator and free list manager.
- *
- * This is the architecture independent part of the block allocator.
- * It requires only the following support from the operating system:
- *
- * void *getMBlock();
- *
- * returns the address of an MBLOCK_SIZE region of memory, aligned on
- * an MBLOCK_SIZE boundary. There is no requirement for successive
- * calls to getMBlock to return strictly increasing addresses.
- *
- * ---------------------------------------------------------------------------*/
-
-#include "PosixSource.h"
-#include "Rts.h"
-#include "RtsFlags.h"
-#include "RtsUtils.h"
-#include "BlockAlloc.h"
-#include "MBlock.h"
-#include "Storage.h"
-
-#include <string.h>
-
-static void initMBlock(void *mblock);
-static bdescr *allocMegaGroup(nat mblocks);
-static void freeMegaGroup(bdescr *bd);
-
-// In THREADED_RTS mode, the free list is protected by sm_mutex.
-static bdescr *free_list = NULL;
-
-/* -----------------------------------------------------------------------------
- Initialisation
- -------------------------------------------------------------------------- */
-
-void initBlockAllocator(void)
-{
- // The free list starts off NULL
-}
-
-/* -----------------------------------------------------------------------------
- Allocation
- -------------------------------------------------------------------------- */
-
-STATIC_INLINE void
-initGroup(nat n, bdescr *head)
-{
- bdescr *bd;
- nat i;
-
- if (n != 0) {
- head->blocks = n;
- head->free = head->start;
- head->link = NULL;
- for (i=1, bd = head+1; i < n; i++, bd++) {
- bd->free = 0;
- bd->blocks = 0;
- bd->link = head;
- }
- }
-}
-
-bdescr *
-allocGroup(nat n)
-{
- void *mblock;
- bdescr *bd, **last;
-
- ASSERT_SM_LOCK();
- ASSERT(n != 0);
-
- if (n > BLOCKS_PER_MBLOCK) {
- return allocMegaGroup(BLOCKS_TO_MBLOCKS(n));
- }
-
- last = &free_list;
- for (bd = free_list; bd != NULL; bd = bd->link) {
- if (bd->blocks == n) { /* exactly the right size! */
- *last = bd->link;
- /* no initialisation necessary - this is already a
- * self-contained block group. */
- bd->free = bd->start; /* block isn't free now */
- bd->link = NULL;
- return bd;
- }
- if (bd->blocks > n) { /* block too big... */
- bd->blocks -= n; /* take a chunk off the *end* */
- bd += bd->blocks;
- initGroup(n, bd); /* initialise it */
- return bd;
- }
- last = &bd->link;
- }
-
- mblock = getMBlock(); /* get a new megablock */
- initMBlock(mblock); /* initialise the start fields */
- bd = FIRST_BDESCR(mblock);
- initGroup(n,bd); /* we know the group will fit */
- if (n < BLOCKS_PER_MBLOCK) {
- initGroup(BLOCKS_PER_MBLOCK-n, bd+n);
- freeGroup(bd+n); /* add the rest on to the free list */
- }
- return bd;
-}
-
-bdescr *
-allocGroup_lock(nat n)
-{
- bdescr *bd;
- ACQUIRE_SM_LOCK;
- bd = allocGroup(n);
- RELEASE_SM_LOCK;
- return bd;
-}
-
-bdescr *
-allocBlock(void)
-{
- return allocGroup(1);
-}
-
-bdescr *
-allocBlock_lock(void)
-{
- bdescr *bd;
- ACQUIRE_SM_LOCK;
- bd = allocBlock();
- RELEASE_SM_LOCK;
- return bd;
-}
-
-/* -----------------------------------------------------------------------------
- Any request larger than BLOCKS_PER_MBLOCK needs a megablock group.
- First, search the free list for enough contiguous megablocks to
- fulfill the request - if we don't have enough, we need to
- allocate some new ones.
-
- A megablock group looks just like a normal block group, except that
- the blocks field in the head will be larger than BLOCKS_PER_MBLOCK.
-
- Note that any objects placed in this group must start in the first
- megablock, since the other blocks don't have block descriptors.
- -------------------------------------------------------------------------- */
-
-static bdescr *
-allocMegaGroup(nat n)
-{
- nat mbs_found;
- bdescr *bd, *last, *grp_start, *grp_prev;
-
- mbs_found = 0;
- grp_start = NULL;
- grp_prev = NULL;
- last = NULL;
- for (bd = free_list; bd != NULL; bd = bd->link) {
-
- if (bd->blocks == BLOCKS_PER_MBLOCK) { /* whole megablock found */
-
- /* is it the first one we've found or a non-contiguous megablock? */
- if (grp_start == NULL ||
- bd->start != last->start + MBLOCK_SIZE/sizeof(W_)) {
- grp_start = bd;
- grp_prev = last;
- mbs_found = 1;
- } else {
- mbs_found++;
- }
-
- if (mbs_found == n) { /* found enough contig megablocks? */
- break;
- }
- }
-
- else { /* only a partial megablock, start again */
- grp_start = NULL;
- }
-
- last = bd;
- }
-
- /* found all the megablocks we need on the free list
- */
- if (mbs_found == n) {
- /* remove the megablocks from the free list */
- if (grp_prev == NULL) { /* bd now points to the last mblock */
- free_list = bd->link;
- } else {
- grp_prev->link = bd->link;
- }
- }
-
- /* the free list wasn't sufficient, allocate all new mblocks.
- */
- else {
- void *mblock = getMBlocks(n);
- initMBlock(mblock); /* only need to init the 1st one */
- grp_start = FIRST_BDESCR(mblock);
- }
-
- /* set up the megablock group */
- initGroup(BLOCKS_PER_MBLOCK, grp_start);
- grp_start->blocks = MBLOCK_GROUP_BLOCKS(n);
- return grp_start;
-}
-
-/* -----------------------------------------------------------------------------
- De-Allocation
- -------------------------------------------------------------------------- */
-
-/* coalesce the group p with p->link if possible.
- *
- * Returns p->link if no coalescing was done, otherwise returns a
- * pointer to the newly enlarged group p.
- */
-
-STATIC_INLINE bdescr *
-coalesce(bdescr *p)
-{
- bdescr *bd, *q;
- nat i, blocks;
-
- q = p->link;
- if (q != NULL && p->start + p->blocks * BLOCK_SIZE_W == q->start) {
- /* can coalesce */
- p->blocks += q->blocks;
- p->link = q->link;
- blocks = q->blocks;
- for (i = 0, bd = q; i < blocks; bd++, i++) {
- bd->free = 0;
- bd->blocks = 0;
- bd->link = p;
- }
- return p;
- }
- return q;
-}
-
-void
-freeGroup(bdescr *p)
-{
- bdescr *bd, *last;
-
- ASSERT_SM_LOCK();
-
- /* are we dealing with a megablock group? */
- if (p->blocks > BLOCKS_PER_MBLOCK) {
- freeMegaGroup(p);
- return;
- }
-
-
- p->free = (void *)-1; /* indicates that this block is free */
- p->step = NULL;
- p->gen_no = 0;
- /* fill the block group with garbage if sanity checking is on */
- IF_DEBUG(sanity,memset(p->start, 0xaa, p->blocks * BLOCK_SIZE));
-
- /* find correct place in free list to place new group */
- last = NULL;
- for (bd = free_list; bd != NULL && bd->start < p->start;
- bd = bd->link) {
- last = bd;
- }
-
- /* now, last = previous group (or NULL) */
- if (last == NULL) {
- p->link = free_list;
- free_list = p;
- } else {
- /* coalesce with previous group if possible */
- p->link = last->link;
- last->link = p;
- p = coalesce(last);
- }
-
- /* coalesce with next group if possible */
- coalesce(p);
- IF_DEBUG(sanity, checkFreeListSanity());
-}
-
-void
-freeGroup_lock(bdescr *p)
-{
- ACQUIRE_SM_LOCK;
- freeGroup(p);
- RELEASE_SM_LOCK;
-}
-
-static void
-freeMegaGroup(bdescr *p)
-{
- nat n;
- void *q = p;
-
- n = ((bdescr *)q)->blocks * BLOCK_SIZE / MBLOCK_SIZE + 1;
- for (; n > 0; q += MBLOCK_SIZE, n--) {
- initMBlock(MBLOCK_ROUND_DOWN(q));
- initGroup(BLOCKS_PER_MBLOCK, (bdescr *)q);
- freeGroup((bdescr *)q);
- }
-}
-
-void
-freeChain(bdescr *bd)
-{
- bdescr *next_bd;
- while (bd != NULL) {
- next_bd = bd->link;
- freeGroup(bd);
- bd = next_bd;
- }
-}
-
-void
-freeChain_lock(bdescr *bd)
-{
- ACQUIRE_SM_LOCK;
- freeChain(bd);
- RELEASE_SM_LOCK;
-}
-
-static void
-initMBlock(void *mblock)
-{
- bdescr *bd;
- void *block;
-
- /* the first few Bdescr's in a block are unused, so we don't want to
- * put them all on the free list.
- */
- block = FIRST_BLOCK(mblock);
- bd = FIRST_BDESCR(mblock);
-
- /* Initialise the start field of each block descriptor
- */
- for (; block <= LAST_BLOCK(mblock); bd += 1, block += BLOCK_SIZE) {
- bd->start = block;
- }
-}
-
-/* -----------------------------------------------------------------------------
- Debugging
- -------------------------------------------------------------------------- */
-
-#ifdef DEBUG
-static void
-checkWellFormedGroup( bdescr *bd )
-{
- nat i;
-
- for (i = 1; i < bd->blocks; i++) {
- ASSERT(bd[i].blocks == 0);
- ASSERT(bd[i].free == 0);
- ASSERT(bd[i].link == bd);
- }
-}
-
-void
-checkFreeListSanity(void)
-{
- bdescr *bd;
-
- for (bd = free_list; bd != NULL; bd = bd->link) {
- IF_DEBUG(block_alloc,
- debugBelch("group at 0x%p, length %ld blocks\n",
- bd->start, (long)bd->blocks));
- ASSERT(bd->blocks > 0);
- checkWellFormedGroup(bd);
- if (bd->link != NULL) {
- /* make sure we're fully coalesced */
- ASSERT(bd->start + bd->blocks * BLOCK_SIZE_W != bd->link->start);
- ASSERT(bd->start < bd->link->start);
- }
- }
-}
-
-nat /* BLOCKS */
-countFreeList(void)
-{
- bdescr *bd;
- lnat total_blocks = 0;
-
- for (bd = free_list; bd != NULL; bd = bd->link) {
- total_blocks += bd->blocks;
- }
- return total_blocks;
-}
-#endif
projects / ghc-hetmet.git / blobdiff