/* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap::heap_allot(cell size, cell type)
{
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
free_heap_block *block = find_free_block(size);
if(block)
{
block = split_free_block(block,size);
block->set_type(type);
block->set_marked_p(false);
return block;
}
else
return NULL;
}
/* Allocate a block of memory from the mark and sweep GC heap */
heap_block *heap::heap_allot(cell size)
{
size = (size + block_size_increment - 1) & ~(block_size_increment - 1);
free_heap_block *block = find_free_block(size);
if(block)
{
block = split_free_block(block,size);
block->status = B_ALLOCATED;
return block;
}
else
return NULL;
}
//
// Allocate a chunk of blocks that is at least min and at most max
// blocks in size. This API is used by the nursery allocator that
// wants contiguous memory preferably, but doesn't require it. When
// memory is fragmented we might have lots of chunks that are
// less than a full megablock, so allowing the nursery allocator to
// use these reduces fragmentation considerably. e.g. on a GHC build
// with +RTS -H, I saw fragmentation go from 17MB down to 3MB on a
// single compile.
//
// Further to this: in #7257 there is a program that creates serious
// fragmentation such that the heap is full of tiny <4 block chains.
// The nursery allocator therefore has to use single blocks to avoid
// fragmentation, but we make sure that we allocate large blocks
// preferably if there are any.
//
bdescr *
allocLargeChunk (W_ min, W_ max)
{
bdescr *bd;
StgWord ln, lnmax;
if (min >= BLOCKS_PER_MBLOCK) {
return allocGroup(max);
}
ln = log_2_ceil(min);
lnmax = log_2_ceil(max); // tops out at MAX_FREE_LIST
while (ln < lnmax && free_list[ln] == NULL) {
ln++;
}
if (ln == lnmax) {
return allocGroup(max);
}
bd = free_list[ln];
if (bd->blocks <= max) // exactly the right size!
{
dbl_link_remove(bd, &free_list[ln]);
initGroup(bd);
}
else // block too big...
{
bd = split_free_block(bd, max, ln);
ASSERT(bd->blocks == max);
initGroup(bd);
}
n_alloc_blocks += bd->blocks;
if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks;
IF_DEBUG(sanity, memset(bd->start, 0xaa, bd->blocks * BLOCK_SIZE));
IF_DEBUG(sanity, checkFreeListSanity());
return bd;
}
/* Place an ADJUSTED sized block in heap */
static void place(void *bp, size_t asize) {
#if DEBUG
if (NEXT_BLKP(bp)) {
if (GET_PREV_ALLOC(GET_HEADER(NEXT_BLKP(bp)))) {
dbg_printf("0x%lx: Fail to inform next block when free\n", (size_t)bp);
exit(2);
}
}
#endif
dbg_printf("=== Place, bp = 0x%lx, adjusted size = %ld \n", (size_t)bp, asize);
/* block free size */
size_t csize = GET_SIZE(GET_HEADER(bp));
char *nextbp = NULL;
int class_idx = 0;
size_t flag = 0;
/* Split, say, minimum block size set to 1 WSIZE = 8 byte */
if ((csize - asize) >= (4 * WSIZE)) {
class_idx = get_class_idx_by_size(GET_SIZE(GET_HEADER(bp)));
/* Include previous block's information */
flag = GET_PREV_ALLOC(GET_HEADER(bp)) ? 0x3 : 0x1;
PUT(GET_HEADER(bp), PACK(asize, flag));
PUT(GET_FOOTER(bp), PACK(asize, flag));
nextbp = NEXT_BLKP(bp);
PUT(GET_HEADER(nextbp), PACK((csize - asize), 0));
PUT(GET_FOOTER(nextbp), PACK((csize - asize), 0));
/* Inform the next block that this block is allocated */
flag = GET(GET_HEADER(nextbp));
flag |= 0x2;
PUT(GET_HEADER(nextbp), flag);
PUT(GET_FOOTER(nextbp), flag);
split_free_block(bp, nextbp);
remove_free_block(bp, class_idx);
remove_free_block(nextbp, class_idx);
insert_first(nextbp);
mm_checkheap(CHECK_HEAP);
}
else {
/* Include previous block's information */
flag = GET_PREV_ALLOC(GET_HEADER(bp)) ? 0x3 : 0x1;
PUT(GET_HEADER(bp), PACK(csize, flag));
PUT(GET_FOOTER(bp), PACK(csize, flag));
/* Inform the next block that this block is allocated */
if ((size_t)bp == 0x800004980) {
dbg_printf("bp size = %ld\n",GET_SIZE(GET_HEADER(bp)));
dbg_printf("NEXT_BLKP(bp); 0x%lx\n",(size_t)NEXT_BLKP(bp));
}
nextbp = NEXT_BLKP(bp);
if (nextbp) {
flag = GET(GET_HEADER(nextbp));
flag |= 0x2;
PUT(GET_HEADER(nextbp), flag);
/* Only put footer when next block is free */
if (!GET_ALLOC(GET_HEADER(nextbp))) {
PUT(GET_FOOTER(nextbp), flag);
}
}
remove_free_block(bp, get_class_idx_by_size(csize));
}
}
bdescr *
allocGroup (W_ n)
{
bdescr *bd, *rem;
StgWord ln;
if (n == 0) barf("allocGroup: requested zero blocks");
if (n >= BLOCKS_PER_MBLOCK)
{
StgWord mblocks;
mblocks = BLOCKS_TO_MBLOCKS(n);
// n_alloc_blocks doesn't count the extra blocks we get in a
// megablock group.
n_alloc_blocks += mblocks * BLOCKS_PER_MBLOCK;
if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks;
bd = alloc_mega_group(mblocks);
// only the bdescrs of the first MB are required to be initialised
initGroup(bd);
goto finish;
}
n_alloc_blocks += n;
if (n_alloc_blocks > hw_alloc_blocks) hw_alloc_blocks = n_alloc_blocks;
ln = log_2_ceil(n);
while (ln < MAX_FREE_LIST && free_list[ln] == NULL) {
ln++;
}
if (ln == MAX_FREE_LIST) {
#if 0 /* useful for debugging fragmentation */
if ((W_)mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W
- (W_)((n_alloc_blocks - n) * BLOCK_SIZE_W) > (2*1024*1024)/sizeof(W_)) {
debugBelch("Fragmentation, wanted %d blocks, %ld MB free\n", n, ((mblocks_allocated * BLOCKS_PER_MBLOCK) - n_alloc_blocks) / BLOCKS_PER_MBLOCK);
RtsFlags.DebugFlags.block_alloc = 1;
checkFreeListSanity();
}
#endif
bd = alloc_mega_group(1);
bd->blocks = n;
initGroup(bd); // we know the group will fit
rem = bd + n;
rem->blocks = BLOCKS_PER_MBLOCK-n;
initGroup(rem); // init the slop
n_alloc_blocks += rem->blocks;
freeGroup(rem); // add the slop on to the free list
goto finish;
}
bd = free_list[ln];
if (bd->blocks == n) // exactly the right size!
{
dbl_link_remove(bd, &free_list[ln]);
initGroup(bd);
}
else if (bd->blocks > n) // block too big...
{
bd = split_free_block(bd, n, ln);
ASSERT(bd->blocks == n);
initGroup(bd);
}
else
{
barf("allocGroup: free list corrupted");
}
finish:
IF_DEBUG(sanity, memset(bd->start, 0xaa, bd->blocks * BLOCK_SIZE));
IF_DEBUG(sanity, checkFreeListSanity());
return bd;
}
