--- /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 %d blocks\n",
+ bd->start, 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