/* This is called by caml_compact_heap. */
void caml_fl_reset (void)
{
Next (Fl_head) = NULL;
switch (policy){
case Policy_next_fit:
fl_prev = Fl_head;
break;
case Policy_first_fit:
truncate_flp (Fl_head);
break;
default:
Assert (0);
break;
}
caml_fl_cur_size = 0;
caml_fl_init_merge ();
}
/* This is a heap extension. We have to insert it in the right place
in the free-list.
[caml_fl_add_blocks] can only be called right after a call to
[caml_fl_allocate] that returned NULL.
Most of the heap extensions are expected to be at the end of the
free list. (This depends on the implementation of [malloc].)
[bp] must point to a list of blocks chained by their field 0,
terminated by NULL, and field 1 of the first block must point to
the last block.
*/
void caml_fl_add_blocks (char *bp)
{
Assert (fl_last != NULL);
Assert (Next (fl_last) == NULL);
caml_fl_cur_size += Whsize_bp (bp);
if (bp > fl_last) {
Next (fl_last) = bp;
if (fl_last == caml_fl_merge && bp < caml_gc_sweep_hp) {
caml_fl_merge = (char *) Field (bp, 1);
}
if (policy == Policy_first_fit && flp_size < FLP_MAX) {
flp [flp_size++] = fl_last;
}
} else {
char *cur, *prev;
prev = Fl_head;
cur = Next (prev);
while (cur != NULL && cur < bp) {
Assert (prev < bp || prev == Fl_head);
/* XXX TODO: extend flp on the fly */
prev = cur;
cur = Next (prev);
}
Assert (prev < bp || prev == Fl_head);
Assert (cur > bp || cur == NULL);
Next (Field (bp, 1)) = cur;
Next (prev) = bp;
/* When inserting blocks between [caml_fl_merge] and [caml_gc_sweep_hp],
we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge]
is always the last free-list block before [caml_gc_sweep_hp]. */
if (prev == caml_fl_merge && bp < caml_gc_sweep_hp) {
caml_fl_merge = (char *) Field (bp, 1);
}
if (policy == Policy_first_fit) truncate_flp (bp);
}
}
/* [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;
}