static void check_block (char *hp)
{
mlsize_t i;
value v = Val_hp (hp);
value f;
check_head (v);
switch (Tag_hp (hp)) {
case Abstract_tag:
break;
case String_tag:
break;
case Double_tag:
Assert (Wosize_val (v) == Double_wosize);
break;
case Double_array_tag:
Assert (Wosize_val (v) % Double_wosize == 0);
break;
case Custom_tag:
Assert (!Is_in_heap (Custom_ops_val (v)));
break;
case Infix_tag:
Assert (0);
break;
default:
Assert (Tag_hp (hp) < No_scan_tag);
for (i = 0; i < Wosize_hp (hp); i++) {
f = Field (v, i);
if (Is_block (f) && Is_in_heap (f)) check_head (f);
}
}
}
CAMLprim value caml_weak_blit (value ars, value ofs,
value ard, value ofd, value len)
{
mlsize_t offset_s = Long_val (ofs) + 1;
mlsize_t offset_d = Long_val (ofd) + 1;
mlsize_t length = Long_val (len);
long i;
Assert (Is_in_heap (ars));
Assert (Is_in_heap (ard));
if (offset_s < 1 || offset_s + length > Wosize_val (ars)){
caml_invalid_argument ("Weak.blit");
}
if (offset_d < 1 || offset_d + length > Wosize_val (ard)){
caml_invalid_argument ("Weak.blit");
}
if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1){
for (i = 0; i < length; i++){
value v = Field (ars, offset_s + i);
if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
&& Is_white_val (v)){
Field (ars, offset_s + i) = caml_weak_none;
}
}
}
if (offset_d < offset_s){
for (i = 0; i < length; i++){
do_set (ard, offset_d + i, Field (ars, offset_s + i));
}
}else{
for (i = length - 1; i >= 0; i--){
do_set (ard, offset_d + i, Field (ars, offset_s + i));
}
}
return Val_unit;
}
static long compare_val(value v1, value v2)
{
tag_t t1, t2;
tailcall:
if (v1 == v2) return 0;
if (Is_long(v1) || Is_long(v2)) return Long_val(v1) - Long_val(v2);
/* If one of the objects is outside the heap (but is not an atom),
use address comparison. */
if ((!Is_atom(v1) && !Is_young(v1) && !Is_in_heap((addr)v1)) ||
(!Is_atom(v2) && !Is_young(v2) && !Is_in_heap((addr)v2)))
return v1 - v2;
t1 = Tag_val(v1);
t2 = Tag_val(v2);
if (t1 != t2) return (long)t1 - (long)t2;
switch(t1) {
case String_tag: {
mlsize_t len1, len2, len;
unsigned char * p1, * p2;
len1 = string_length(v1);
len2 = string_length(v2);
for (len = (len1 <= len2 ? len1 : len2),
p1 = (unsigned char *) String_val(v1),
p2 = (unsigned char *) String_val(v2);
len > 0;
len--, p1++, p2++)
if (*p1 != *p2) return (long)*p1 - (long)*p2;
return len1 - len2;
}
case Double_tag: {
double d1 = Double_val(v1);
double d2 = Double_val(v2);
if (d1 == d2) return 0; else if (d1 < d2) return -1; else return 1;
}
case Abstract_tag:
case Final_tag:
invalid_argument("equal: abstract value");
case Closure_tag:
invalid_argument("equal: functional value");
default: {
mlsize_t sz1 = Wosize_val(v1);
mlsize_t sz2 = Wosize_val(v2);
value * p1, * p2;
long res;
if (sz1 != sz2) return sz1 - sz2;
for(p1 = Op_val(v1), p2 = Op_val(v2);
sz1 > 1;
sz1--, p1++, p2++) {
res = compare_val(*p1, *p2);
if (res != 0) return res;
}
v1 = *p1;
v2 = *p2;
goto tailcall;
}
}
}
static void fl_check (void)
{
char *cur, *prev;
int prev_found = 0, flp_found = 0, merge_found = 0;
uintnat size_found = 0;
int sz = 0;
prev = Fl_head;
cur = Next (prev);
while (cur != NULL){
size_found += Whsize_bp (cur);
Assert (Is_in_heap (cur));
if (cur == fl_prev) prev_found = 1;
if (policy == Policy_first_fit && Wosize_bp (cur) > sz){
sz = Wosize_bp (cur);
if (flp_found < flp_size){
Assert (Next (flp[flp_found]) == cur);
++ flp_found;
}else{
Assert (beyond == NULL || cur >= Next (beyond));
}
}
if (cur == caml_fl_merge) merge_found = 1;
prev = cur;
cur = Next (prev);
}
if (policy == Policy_next_fit) Assert (prev_found || fl_prev == Fl_head);
if (policy == Policy_first_fit) Assert (flp_found == flp_size);
Assert (merge_found || caml_fl_merge == Fl_head);
Assert (size_found == caml_fl_cur_size);
}
/* [caml_fl_allocate] does not set the header of the newly allocated block.
The calling function must do it before any GC function gets called.
[caml_fl_allocate] returns a head pointer.
*/
char *caml_fl_allocate (mlsize_t wo_sz)
{
char *cur, *prev;
Assert (sizeof (char *) == sizeof (value));
Assert (fl_prev != NULL);
Assert (wo_sz >= 1);
/* Search from [fl_prev] to the end of the list. */
prev = fl_prev;
cur = Next (prev);
while (cur != NULL){ Assert (Is_in_heap (cur));
if (Wosize_bp (cur) >= wo_sz){
return allocate_block (Whsize_wosize (wo_sz), prev, cur);
}
prev = cur;
cur = Next (prev);
}
fl_last = prev;
/* Search from the start of the list to [fl_prev]. */
prev = Fl_head;
cur = Next (prev);
while (prev != fl_prev){
if (Wosize_bp (cur) >= wo_sz){
return allocate_block (Whsize_wosize (wo_sz), prev, cur);
}
prev = cur;
cur = Next (prev);
}
/* No suitable block was found. */
return NULL;
}
/* [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);
}
CAMLprim value caml_weak_check (value ar, value n)
{
mlsize_t offset = Long_val (n) + 1;
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
return Val_bool (Field (ar, offset) != caml_weak_none);
}
static int sml_equal_aux(value v1, value v2)
{
mlsize_t i;
value * p1, * p2;
again:
if (v1 == v2) return 1;
if (IS_LONG(v1) || IS_LONG(v2)) return 0;
if (!Is_in_heap(v1) && !Is_young(v1)) return 0;
if (!Is_in_heap(v2) && !Is_young(v2)) return 0;
if (Tag_val(v1) != Tag_val(v2)) return 0;
switch(Tag_val(v1)) {
case String_tag:
{
// Fast string comparison
size_t len = string_length(v1);
if (len != string_length(v2)) {
return 0;
}
return (strncmp((char *) String_val(v1),
(char *) String_val(v2),
len) == 0) ? 1 : 0;
}
case Double_tag:
return (Double_val(v1) == Double_val(v2));
case Reference_tag: /* Different reference cells are not equal! */
case Abstract_tag:
case Final_tag:
return 0;
case Closure_tag:
invalid_argument("sml_equal: functional value");
default:
i = Wosize_val(v1);
if (i != Wosize_val(v2)) return 0;
for(p1 = Op_val(v1), p2 = Op_val(v2);
i > 1;
i--, p1++, p2++)
if (!sml_equal_aux(*p1, *p2)) return 0;
v1 = *p1;
v2 = *p2; /* Tail-call */
goto again;
}
}
/* [caml_initialize] never calls the GC, so you may call it while an block is
unfinished (i.e. just after a call to [caml_alloc_shr].) */
void caml_initialize (value *fp, value val)
{
*fp = val;
if (Is_block (val) && Is_young (val) && Is_in_heap (fp)){
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
}
}
CAMLexport void caml_remove_generational_global_root_r(CAML_R, value *r)
{
value v = *r;
if (Is_block(v)) {
if (Is_young(v))
caml_delete_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(v))
caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
}
}
/* [initialize] never calls the GC, so you may call it while an object is
unfinished (i.e. just after a call to [alloc_shr].) */
void initialize (value * fp, value val)
{
*fp = val;
Assert (Is_in_heap (fp));
if (Is_block (val) && Is_young (val)){
*ref_table_ptr++ = fp;
if (ref_table_ptr >= ref_table_limit){
realloc_ref_table ();
}
}
}
/* PR#6084 workaround: define it as a weak symbol */
CAMLexport CAMLweakdef void caml_initialize (value *fp, value val)
{
CAMLassert(Is_in_heap(fp));
*fp = val;
if (Is_block (val) && Is_young (val)) {
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
}
}
CAMLexport void caml_register_generational_global_root_r(CAML_R, value *r)
{
value v = *r;
Assert (((intnat) r & 3) == 0); /* compact.c demands this (for now) */
if (Is_block(v)) {
if (Is_young(v))
caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(v))
caml_insert_global_root_r(ctx, &caml_global_roots_old, r);
}
}
CAMLprim value caml_get_current_callstack(value max_frames_value) {
CAMLparam1(max_frames_value);
CAMLlocal1(trace);
/* we use `intnat` here because, were it only `int`, passing `max_int`
from the OCaml side would overflow on 64bits machines. */
intnat max_frames = Long_val(max_frames_value);
intnat trace_size;
/* first compute the size of the trace */
{
uintnat pc = caml_last_return_address;
/* note that [caml_bottom_of_stack] always points to the most recent
* frame, independently of the [Stack_grows_upwards] setting */
char * sp = caml_bottom_of_stack;
char * limitsp = caml_top_of_stack;
trace_size = 0;
while (1) {
frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
if (descr == NULL) break;
if (trace_size >= max_frames) break;
++trace_size;
#ifndef Stack_grows_upwards
if (sp > limitsp) break;
#else
if (sp < limitsp) break;
#endif
}
}
trace = caml_alloc((mlsize_t) trace_size, Abstract_tag);
/* then collect the trace */
{
uintnat pc = caml_last_return_address;
char * sp = caml_bottom_of_stack;
intnat trace_pos;
for (trace_pos = 0; trace_pos < trace_size; trace_pos++) {
frame_descr * descr = caml_next_frame_descriptor(&pc, &sp);
Assert(descr != NULL);
/* The assignment below is safe without [caml_initialize], even
if the trace is large and allocated on the old heap, because
we assign values that are outside the OCaml heap. */
Assert(!(Is_block((value) descr) && Is_in_heap((value) descr)));
Field(trace, trace_pos) = (value) descr;
}
}
CAMLreturn(trace);
}
CAMLprim value caml_weak_get (value ar, value n)
{
CAMLparam2 (ar, n);
mlsize_t offset = Long_val (n) + 1;
CAMLlocal2 (res, elt);
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
if (Field (ar, offset) == caml_weak_none){
res = None_val;
}else{
elt = Field (ar, offset);
if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){
caml_darken (elt, NULL);
}
res = caml_alloc_small (1, Some_tag);
Field (res, 0) = elt;
}
CAMLreturn (res);
}
CAMLprim value caml_weak_get_copy (value ar, value n)
{
CAMLparam2 (ar, n);
mlsize_t offset = Long_val (n) + 1;
CAMLlocal2 (res, elt);
value v; /* Caution: this is NOT a local root. */
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.get");
}
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Is_block (v) && Is_in_heap_or_young(v)) {
elt = caml_alloc (Wosize_val (v), Tag_val (v));
/* The GC may erase or move v during this call to caml_alloc. */
v = Field (ar, offset);
if (v == caml_weak_none) CAMLreturn (None_val);
if (Tag_val (v) < No_scan_tag){
mlsize_t i;
for (i = 0; i < Wosize_val (v); i++){
value f = Field (v, i);
if (caml_gc_phase == Phase_mark && Is_block (f) && Is_in_heap (f)){
caml_darken (f, NULL);
}
Modify (&Field (elt, i), f);
}
}else{
memmove (Bp_val (elt), Bp_val (v), Bosize_val (v));
}
}else{
elt = v;
}
res = caml_alloc_small (1, Some_tag);
Field (res, 0) = elt;
CAMLreturn (res);
}
/* Check that [v]'s header looks good. [v] must be a block in the heap. */
static void check_head (value v)
{
Assert (Is_block (v));
Assert (Is_in_heap (v));
Assert (Wosize_val (v) != 0);
Assert (Color_hd (Hd_val (v)) != Caml_blue);
Assert (Is_in_heap (v));
if (Tag_val (v) == Infix_tag){
int offset = Wsize_bsize (Infix_offset_val (v));
value trueval = Val_op (&Field (v, -offset));
Assert (Tag_val (trueval) == Closure_tag);
Assert (Wosize_val (trueval) > offset);
Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
}else{
Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
}
if (Tag_val (v) == Double_tag){
Assert (Wosize_val (v) == Double_wosize);
}else if (Tag_val (v) == Double_array_tag){
Assert (Wosize_val (v) % Double_wosize == 0);
}
}
CAMLexport void caml_modify_generational_global_root_r(CAML_R, value *r, value newval)
{
value oldval = *r;
/* It is OK to have a root in roots_young that suddenly points to
the old generation -- the next minor GC will take care of that.
What needs corrective action is a root in roots_old that suddenly
points to the young generation. */
if (Is_block(newval) && Is_young(newval) &&
Is_block(oldval) && Is_in_heap(oldval)) {
caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
}
/* PR#4704 */
else if (!Is_block(oldval) && Is_block(newval)) {
/* The previous value in the root was unboxed but now it is boxed.
The root won't appear in any of the root lists thus far (by virtue
of the operation of [caml_register_generational_global_root]), so we
need to make sure it gets in, or else it will never be scanned. */
if (Is_young(newval))
caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(newval))
caml_insert_global_root_r(ctx, &caml_global_roots_old, r);
}
else if (Is_block(oldval) && !Is_block(newval)) {
/* The previous value in the root was boxed but now it is unboxed, so
the root should be removed. If [oldval] is young, this will happen
anyway at the next minor collection, but it is safer to delete it
here. */
if (Is_young(oldval))
caml_delete_global_root_r(ctx, &caml_global_roots_young, r);
else if (Is_in_heap(oldval))
caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
}
/* end PR#4704 */
*r = newval;
}
void caml_modify (value *fp, value val)
{
value _old_ = *(fp);
*(fp) = (val);
if (Is_in_heap (fp)){
if (caml_gc_phase == Phase_mark) caml_darken (_old_, NULL);
if (Is_block (val) && Is_young (val)
&& ! (Is_block (_old_) && Is_young (_old_))){
if (caml_ref_table.ptr >= caml_ref_table.limit){
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = (fp);
}
}
}
CAMLprim value caml_weak_set (value ar, value n, value el)
{
mlsize_t offset = Long_val (n) + 1;
Assert (Is_in_heap (ar));
if (offset < 1 || offset >= Wosize_val (ar)){
caml_invalid_argument ("Weak.set");
}
if (el != None_val && Is_block (el)){
Assert (Wosize_val (el) == 1);
do_set (ar, offset, Field (el, 0));
}else{
Field (ar, offset) = caml_weak_none;
}
return Val_unit;
}
void svec_finalize2(value obj)
{
svec_final2_fun ffunp = SvecFinalize2_val(obj);
/* See the comment on svec_finalize, above. */
if (ffunp && !(Is_in_heap(*Svec_val(obj)))) {
if (jit_ffi_debug)
fprintf(stderr,"svec_finalize2: calling %p to finalize %p(length=%d).\n",
(void *) ffunp,*Svec_val(obj),(size_t) Field(obj, 4));
(*ffunp) (*Svec_val(obj), Field(obj, 4));
Field(obj,3) = (value)NULL;
*(Svec_val(obj)) = NULL;
}
return;
}
CAMLexport value caml_alloc_shr (mlsize_t wosize, tag_t tag)
{
header_t *hp;
value *new_block;
if (wosize > Max_wosize) caml_raise_out_of_memory ();
hp = caml_fl_allocate (wosize);
if (hp == NULL){
new_block = expand_heap (wosize);
if (new_block == NULL) {
if (caml_in_minor_collection)
caml_fatal_error ("Fatal error: out of memory.\n");
else
caml_raise_out_of_memory ();
}
caml_fl_add_blocks ((value) new_block);
hp = caml_fl_allocate (wosize);
}
Assert (Is_in_heap (Val_hp (hp)));
/* Inline expansion of caml_allocation_color. */
if (caml_gc_phase == Phase_mark
|| (caml_gc_phase == Phase_sweep && (addr)hp >= (addr)caml_gc_sweep_hp)){
Hd_hp (hp) = Make_header (wosize, tag, Caml_black);
}else{
Assert (caml_gc_phase == Phase_idle
|| (caml_gc_phase == Phase_sweep
&& (addr)hp < (addr)caml_gc_sweep_hp));
Hd_hp (hp) = Make_header (wosize, tag, Caml_white);
}
Assert (Hd_hp (hp) == Make_header (wosize, tag, caml_allocation_color (hp)));
caml_allocated_words += Whsize_wosize (wosize);
if (caml_allocated_words > caml_minor_heap_wsz){
caml_urge_major_slice ();
}
#ifdef DEBUG
{
uintnat i;
for (i = 0; i < wosize; i++){
Field (Val_hp (hp), i) = Debug_uninit_major;
}
}
#endif
return Val_hp (hp);
}
void fl_check ()
{
char *cur, *prev;
int prev_found = 0, merge_found = 0;
prev = Fl_head;
cur = Next (prev);
while (cur != NULL){
Assert (Is_in_heap (cur));
if (cur == fl_prev) prev_found = 1;
if (cur == fl_merge) merge_found = 1;
prev = cur;
cur = Next (prev);
}
Assert (prev_found || fl_prev == Fl_head);
Assert (merge_found || fl_merge == Fl_head);
}
void modify (value *fp, value val)
{
value old = *(fp);
*(fp) = val;
if (Is_in_heap (fp)) {
if (gc_phase == Phase_mark) {
darken(old);
}
if (IS_BLOCK(val) && Is_young (val)
&& ! (IS_BLOCK(old) && Is_young (old))) {
*ref_table_ptr++ = (fp);
if (ref_table_ptr >= ref_table_limit) {
assert (ref_table_ptr == ref_table_limit);
realloc_ref_table();
}
}
}
}
CAMLexport CAMLweakdef void caml_modify (value *fp, value val)
{
/* The write barrier implemented by [caml_modify] checks for the
following two conditions and takes appropriate action:
1- a pointer from the major heap to the minor heap is created
--> add [fp] to the remembered set
2- a pointer from the major heap to the major heap is overwritten,
while the GC is in the marking phase
--> call [caml_darken] on the overwritten pointer so that the
major GC treats it as an additional root.
*/
value old;
if (Is_young((value)fp)) {
/* The modified object resides in the minor heap.
Conditions 1 and 2 cannot occur. */
*fp = val;
} else {
/* The modified object resides in the major heap. */
CAMLassert(Is_in_heap(fp));
old = *fp;
*fp = val;
if (Is_block(old)) {
/* If [old] is a pointer within the minor heap, we already
have a major->minor pointer and [fp] is already in the
remembered set. Conditions 1 and 2 cannot occur. */
if (Is_young(old)) return;
/* Here, [old] can be a pointer within the major heap.
Check for condition 2. */
if (caml_gc_phase == Phase_mark) caml_darken(old, NULL);
}
/* Check for condition 1. */
if (Is_block(val) && Is_young(val)) {
/* Add [fp] to remembered set */
if (caml_ref_table.ptr >= caml_ref_table.limit){
CAMLassert (caml_ref_table.ptr == caml_ref_table.limit);
caml_realloc_ref_table (&caml_ref_table);
}
*caml_ref_table.ptr++ = fp;
}
}
}
static void fl_check (void)
{
char *cur, *prev;
int prev_found = 0, merge_found = 0;
uintnat size_found = 0;
prev = Fl_head;
cur = Next (prev);
while (cur != NULL){
size_found += Whsize_bp (cur);
Assert (Is_in_heap (cur));
if (cur == fl_prev) prev_found = 1;
if (cur == caml_fl_merge) merge_found = 1;
prev = cur;
cur = Next (prev);
}
Assert (prev_found || fl_prev == Fl_head);
Assert (merge_found || caml_fl_merge == Fl_head);
Assert (size_found == caml_fl_cur_size);
}
void svec_finalize(value obj)
{
svec_final_fun ffunp = SvecFinalize_val(obj);
/* See the mosml_ffi_* functions in mem.c for the in-memory format
of the blocks allocated. They are meant to look exactly like
objects of type String.string or Word8Vector.vector. This fools
the interpreter and so aliasing one of these things with a val
binding will create an on-heap copy of the whole buffer. So we
only trigger the finalise function when the object is
off-heap. */
if (ffunp && !(Is_in_heap(*Svec_val(obj)))) {
if (jit_ffi_debug)
fprintf(stderr,"svec_finalise: calling %p to finalise %p.\n",
(void *) ffunp,*Svec_val(obj));
(*ffunp) (*Svec_val(obj));
Field(obj,3) = (value)NULL;
*(Svec_val(obj)) = NULL;
}
return;
}
/* [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);
}
EXTERN value alloc_shr (mlsize_t wosize, tag_t tag)
{
char *hp, *new_block;
hp = fl_allocate (wosize);
if (hp == NULL){
new_block = expand_heap (wosize);
if (new_block == NULL) raise_out_of_memory ();
fl_add_block (new_block);
hp = fl_allocate (wosize);
if (hp == NULL) fatal_error ("alloc_shr: expand heap failed\n");
}
Assert (Is_in_heap (Val_hp (hp)));
if (gc_phase == Phase_mark || (addr)hp >= (addr)gc_sweep_hp){
Hd_hp (hp) = Make_header (wosize, tag, Black);
}else{
Hd_hp (hp) = Make_header (wosize, tag, White);
}
allocated_words += Whsize_wosize (wosize);
if (allocated_words > Wsize_bsize (minor_heap_size)) force_minor_gc ();
return Val_hp (hp);
}
/* [caml_fl_allocate] does not set the header of the newly allocated block.
The calling function must do it before any GC function gets called.
[caml_fl_allocate] returns a head pointer.
*/
char *caml_fl_allocate (mlsize_t wo_sz)
{
char *cur = NULL, *prev, *result;
int i;
mlsize_t sz, prevsz;
Assert (sizeof (char *) == sizeof (value));
Assert (wo_sz >= 1);
switch (policy){
case Policy_next_fit:
Assert (fl_prev != NULL);
/* Search from [fl_prev] to the end of the list. */
prev = fl_prev;
cur = Next (prev);
while (cur != NULL){ Assert (Is_in_heap (cur));
if (Wosize_bp (cur) >= wo_sz){
return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur);
}
prev = cur;
cur = Next (prev);
}
fl_last = prev;
/* Search from the start of the list to [fl_prev]. */
prev = Fl_head;
cur = Next (prev);
while (prev != fl_prev){
if (Wosize_bp (cur) >= wo_sz){
return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur);
}
prev = cur;
cur = Next (prev);
}
/* No suitable block was found. */
return NULL;
break;
case Policy_first_fit: {
/* Search in the flp array. */
for (i = 0; i < flp_size; i++){
sz = Wosize_bp (Next (flp[i]));
if (sz >= wo_sz){
#if FREELIST_DEBUG
if (i > 5) fprintf (stderr, "FLP: found at %d size=%d\n", i, wo_sz);
#endif
result = allocate_block (Whsize_wosize (wo_sz), i, flp[i],
Next (flp[i]));
goto update_flp;
}
}
/* Extend the flp array. */
if (flp_size == 0){
prev = Fl_head;
prevsz = 0;
}else{
prev = Next (flp[flp_size - 1]);
prevsz = Wosize_bp (prev);
if (beyond != NULL) prev = beyond;
}
while (flp_size < FLP_MAX){
cur = Next (prev);
if (cur == NULL){
fl_last = prev;
beyond = (prev == Fl_head) ? NULL : prev;
return NULL;
}else{
sz = Wosize_bp (cur);
if (sz > prevsz){
flp[flp_size] = prev;
++ flp_size;
if (sz >= wo_sz){
beyond = cur;
i = flp_size - 1;
#if FREELIST_DEBUG
if (flp_size > 5){
fprintf (stderr, "FLP: extended to %d\n", flp_size);
}
#endif
result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev,
cur);
goto update_flp;
}
prevsz = sz;
}
}
prev = cur;
}
beyond = cur;
/* The flp table is full. Do a slow first-fit search. */
#if FREELIST_DEBUG
fprintf (stderr, "FLP: table is full -- slow first-fit\n");
#endif
if (beyond != NULL){
prev = beyond;
}else{
prev = flp[flp_size - 1];
}
prevsz = Wosize_bp (Next (flp[FLP_MAX-1]));
Assert (prevsz < wo_sz);
cur = Next (prev);
while (cur != NULL){
Assert (Is_in_heap (cur));
sz = Wosize_bp (cur);
if (sz < prevsz){
beyond = cur;
}else if (sz >= wo_sz){
return allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur);
}
prev = cur;
cur = Next (prev);
}
fl_last = prev;
return NULL;
update_flp: /* (i, sz) */
/* The block at [i] was removed or reduced. Update the table. */
Assert (0 <= i && i < flp_size + 1);
if (i < flp_size){
if (i > 0){
prevsz = Wosize_bp (Next (flp[i-1]));
}else{
prevsz = 0;
}
if (i == flp_size - 1){
if (Wosize_bp (Next (flp[i])) <= prevsz){
beyond = Next (flp[i]);
-- flp_size;
}else{
beyond = NULL;
}
}else{
char *buf [FLP_MAX];
int j = 0;
mlsize_t oldsz = sz;
prev = flp[i];
while (prev != flp[i+1]){
cur = Next (prev);
sz = Wosize_bp (cur);
if (sz > prevsz){
buf[j++] = prev;
prevsz = sz;
if (sz >= oldsz){
Assert (sz == oldsz);
break;
}
}
prev = cur;
}
#if FREELIST_DEBUG
if (j > 2) fprintf (stderr, "FLP: update; buf size = %d\n", j);
#endif
if (FLP_MAX >= flp_size + j - 1){
if (j != 1){
memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (flp_size-i-1));
}
if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j);
flp_size += j - 1;
}else{
if (FLP_MAX > i + j){
if (j != 1){
memmove (&flp[i+j], &flp[i+1], sizeof (block *) * (FLP_MAX-i-j));
}
if (j > 0) memmove (&flp[i], &buf[0], sizeof (block *) * j);
}else{
if (i != FLP_MAX){
memmove (&flp[i], &buf[0], sizeof (block *) * (FLP_MAX - i));
}
}
flp_size = FLP_MAX - 1;
beyond = Next (flp[FLP_MAX - 1]);
}
}
}
return result;
}
break;
default:
Assert (0); /* unknown policy */
break;
}
return NULL; /* NOT REACHED */
}
