/* [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; }