/* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free
block and the desired size, it allocates a new block from the free
block. There are three cases:
0. The free block has the desired size. Detach the block from the
free-list and return it.
1. The free block is 1 word longer than the desired size. Detach
the block from the free list. The remaining word cannot be linked:
turn it into an empty block (header only), and return the rest.
2. The free block is big enough. Split it in two and return the right
block.
In all cases, the allocated block is right-justified in the free block:
it is located in the high-address words of the free block. This way,
the linking of the free-list does not change in case 2.
*/
static char *allocate_block (mlsize_t wh_sz, int flpi, char *prev, char *cur)
{
header_t h = Hd_bp (cur);
Assert (Whsize_hd (h) >= wh_sz);
if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */
caml_fl_cur_size -= Whsize_hd (h);
Next (prev) = Next (cur);
Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
if (caml_fl_merge == cur) caml_fl_merge = prev;
#ifdef DEBUG
fl_last = NULL;
#endif
/* In case 1, the following creates the empty block correctly.
In case 0, it gives an invalid header to the block. The function
calling [caml_fl_allocate] will overwrite it. */
Hd_op (cur) = Make_header (0, 0, Caml_white);
if (policy == Policy_first_fit){
if (flpi + 1 < flp_size && flp[flpi + 1] == cur){
flp[flpi + 1] = prev;
}else if (flpi == flp_size - 1){
beyond = (prev == Fl_head) ? NULL : prev;
-- flp_size;
}
}
}else{ /* Case 2. */
caml_fl_cur_size -= wh_sz;
Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
}
if (policy == Policy_next_fit) fl_prev = prev;
return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
}
value caml_aligned_array_create(size_t alignment, value len)
{
CAMLparam1 (len);
void* bp;
mlsize_t bosize;
int result;
bosize = (Int_val(len) + 1) * alignment;
result = posix_memalign(&bp, alignment, bosize);
if (result != 0)
{
if (result == EINVAL)
caml_failwith(
"The alignment was not a power of two, or was not a multiple of sizeof(void *)");
else if (result == ENOMEM)
caml_raise_out_of_memory();
else
caml_failwith("Unrecognized error");
}
/* Leave space for the header */
bp += alignment;
Hd_bp (bp) =
Make_header (Wosize_bhsize(Bhsize_bosize(bosize - alignment)),
Double_array_tag, Caml_white);
CAMLreturn (Val_bp(bp));
}
/* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free
block and the desired size, it allocates a new block from the free
block. There are three cases:
0. The free block has the desired size. Detach the block from the
free-list and return it.
1. The free block is 1 word longer than the desired size. Detach
the block from the free list. The remaining word cannot be linked:
turn it into an empty block (header only), and return the rest.
2. The free block is big enough. Split it in two and return the right
block.
In all cases, the allocated block is right-justified in the free block:
it is located in the high-address words of the free block. This way,
the linking of the free-list does not change in case 2.
*/
static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur)
{
header_t h = Hd_bp (cur);
Assert (Whsize_hd (h) >= wh_sz);
if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */
caml_fl_cur_size -= Whsize_hd (h);
Next (prev) = Next (cur);
Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
if (caml_fl_merge == cur) caml_fl_merge = prev;
#ifdef DEBUG
fl_last = NULL;
#endif
/* In case 1, the following creates the empty block correctly.
In case 0, it gives an invalid header to the block. The function
calling [caml_fl_allocate] will overwrite it. */
Hd_op (cur) = Make_header (0, 0, Caml_white);
}else{ /* Case 2. */
caml_fl_cur_size -= wh_sz;
Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
}
fl_prev = prev;
return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
}
/* [caml_fl_merge_block] returns the head pointer of the next block after [bp],
because merging blocks may change the size of [bp]. */
char *caml_fl_merge_block (char *bp)
{
char *prev, *cur, *adj;
header_t hd = Hd_bp (bp);
mlsize_t prev_wosz;
caml_fl_cur_size += Whsize_hd (hd);
#ifdef DEBUG
caml_set_fields (bp, 0, Debug_free_major);
#endif
prev = caml_fl_merge;
cur = Next (prev);
/* The sweep code makes sure that this is the right place to insert
this block: */
Assert (prev < bp || prev == Fl_head);
Assert (cur > bp || cur == NULL);
if (policy == Policy_first_fit) truncate_flp (prev);
/* If [last_fragment] and [bp] are adjacent, merge them. */
if (last_fragment == Hp_bp (bp)){
mlsize_t bp_whsz = Whsize_bp (bp);
if (bp_whsz <= Max_wosize){
hd = Make_header (bp_whsz, 0, Caml_white);
bp = last_fragment;
Hd_bp (bp) = hd;
caml_fl_cur_size += Whsize_wosize (0);
}
}
/* If [bp] and [cur] are adjacent, remove [cur] from the free-list
and merge them. */
adj = bp + Bosize_hd (hd);
if (adj == Hp_bp (cur)){
char *next_cur = Next (cur);
mlsize_t cur_whsz = Whsize_bp (cur);
if (Wosize_hd (hd) + cur_whsz <= Max_wosize){
Next (prev) = next_cur;
if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev;
hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue);
Hd_bp (bp) = hd;
adj = bp + Bosize_hd (hd);
#ifdef DEBUG
fl_last = NULL;
Next (cur) = (char *) Debug_free_major;
Hd_bp (cur) = Debug_free_major;
#endif
cur = next_cur;
}
}
/* If [prev] and [bp] are adjacent merge them, else insert [bp] into
the free-list if it is big enough. */
prev_wosz = Wosize_bp (prev);
if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp)
&& prev_wosz + Whsize_hd (hd) < Max_wosize){
Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue);
#ifdef DEBUG
Hd_bp (bp) = Debug_free_major;
#endif
Assert (caml_fl_merge == prev);
}else if (Wosize_hd (hd) != 0){
Hd_bp (bp) = Bluehd_hd (hd);
Next (bp) = cur;
Next (prev) = bp;
caml_fl_merge = bp;
}else{
/* This is a fragment. Leave it in white but remember it for eventual
merging with the next block. */
last_fragment = bp;
caml_fl_cur_size -= Whsize_wosize (0);
}
return adj;
}
