diff options
Diffstat (limited to 'runtime/freelist.c')
-rw-r--r-- | runtime/freelist.c | 1741 |
1 files changed, 1502 insertions, 239 deletions
diff --git a/runtime/freelist.c b/runtime/freelist.c index fbd2332444..2cbaa0a77e 100644 --- a/runtime/freelist.c +++ b/runtime/freelist.c @@ -23,6 +23,7 @@ #include <string.h> #include "caml/config.h" +#include "caml/custom.h" #include "caml/freelist.h" #include "caml/gc.h" #include "caml/gc_ctrl.h" @@ -31,15 +32,72 @@ #include "caml/misc.h" #include "caml/mlvalues.h" +/*************** declarations common to all policies ******************/ + +/* A block in a small free list is a [value] (integer representing a + pointer to the first word after the block's header). The end of the + list is NULL. +*/ +#define Val_NULL ((value) NULL) + +asize_t caml_fl_cur_wsz = 0; /* Number of words in the free set, + including headers but not fragments. */ + +value caml_fl_merge = Val_NULL; /* Current insertion pointer. Managed + jointly with [sweep_slice]. */ + +/* Next in list */ +#define Next_small(v) Field ((v), 0) + +/* Next in memory order */ +static inline value Next_in_mem (value v) { + return (value) &Field ((v), Whsize_val (v)); +} + +#ifdef CAML_INSTR +static uintnat instr_size [20] = + {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0}; +static char *instr_name [20] = { + NULL, + "alloc01@", + "alloc02@", + "alloc03@", + "alloc04@", + "alloc05@", + "alloc06@", + "alloc07@", + "alloc08@", + "alloc09@", + "alloc10-19@", + "alloc20-29@", + "alloc30-39@", + "alloc40-49@", + "alloc50-59@", + "alloc60-69@", + "alloc70-79@", + "alloc80-89@", + "alloc90-99@", + "alloc_large@", +}; +uintnat caml_instr_alloc_jump = 0; +/* number of pointers followed to allocate from the free set */ + +#define INSTR_alloc_jump(n) (caml_instr_alloc_jump += (n)) + +#else + +#define INSTR_alloc_jump(n) ((void)0) + +#endif /*CAML_INSTR*/ + + +/********************* next-fit allocation policy *********************/ + /* The free-list is kept sorted by increasing addresses. This makes the merging of adjacent free blocks possible. - (See [caml_fl_merge_block].) + (See [nf_merge_block].) */ -/* A free list block is a [value] (integer representing a pointer to the - first word after the block's header). The end of the list is NULL. */ -#define Val_NULL ((value) NULL) - /* The sentinel can be located anywhere in memory, but it must not be adjacent to any heap object. */ static struct { @@ -47,66 +105,37 @@ static struct { header_t h; value first_field; value filler2; /* Make sure the sentinel is never adjacent to any block. */ -} sentinel = {0, Make_header (0, 0, Caml_blue), Val_NULL, 0}; - -#define Fl_head (Val_bp (&(sentinel.first_field))) -static value fl_prev = Fl_head; /* Current allocation pointer. */ -static value fl_last = Val_NULL; /* Last block in the list. Only valid - just after [caml_fl_allocate] returns NULL. */ -value caml_fl_merge = Fl_head; /* Current insertion pointer. Managed - jointly with [sweep_slice]. */ -asize_t caml_fl_cur_wsz = 0; /* Number of words in the free list, - including headers but not fragments. */ - -#define FLP_MAX 1000 -static value flp [FLP_MAX]; -static int flp_size = 0; -static value beyond = Val_NULL; +} nf_sentinel = {0, Make_header (0, 0, Caml_blue), Val_NULL, 0}; -#define Next(b) (Field (b, 0)) +#define Nf_head (Val_bp (&(nf_sentinel.first_field))) -#define Policy_next_fit 0 -#define Policy_first_fit 1 -uintnat caml_allocation_policy = Policy_next_fit; -#define policy caml_allocation_policy +static value nf_prev = Nf_head; /* Current allocation pointer. */ +static value nf_last = Val_NULL; /* Last block in the list. Only valid + just after [nf_allocate] returns NULL. */ -#ifdef DEBUG -static void fl_check (void) +#if defined (DEBUG) || FREELIST_DEBUG +static void nf_check (void) { - value cur, prev; - int prev_found = 0, flp_found = 0, merge_found = 0; + value cur; + int prev_found = 0, merge_found = 0; uintnat size_found = 0; - int sz = 0; - prev = Fl_head; - cur = Next (prev); + cur = Next_small (Nf_head); while (cur != Val_NULL){ size_found += Whsize_bp (cur); CAMLassert (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){ - CAMLassert (Next (flp[flp_found]) == cur); - ++ flp_found; - }else{ - CAMLassert (beyond == Val_NULL - || Bp_val (cur) >= Bp_val (Next (beyond))); - } - } + if (cur == nf_prev) prev_found = 1; if (cur == caml_fl_merge) merge_found = 1; - prev = cur; - cur = Next (prev); + cur = Next_small (cur); } - if (policy == Policy_next_fit) CAMLassert (prev_found || fl_prev == Fl_head); - if (policy == Policy_first_fit) CAMLassert (flp_found == flp_size); - CAMLassert (merge_found || caml_fl_merge == Fl_head); + CAMLassert (prev_found || nf_prev == Nf_head); + CAMLassert (merge_found || caml_fl_merge == Nf_head); CAMLassert (size_found == caml_fl_cur_wsz); } -#endif +#endif /* DEBUG || FREELIST_DEBUG */ -/* [allocate_block] is called by [caml_fl_allocate]. Given a suitable free +/* [nf_allocate_block] is called by [nf_allocate]. Given a suitable free block and the requested size, it allocates a new block from the free block. There are three cases: 0. The free block has the requested size. Detach the block from the @@ -120,78 +149,34 @@ static void fl_check (void) it is located in the high-address words of the free block, so that the linking of the free-list does not change in case 2. */ -static header_t *allocate_block (mlsize_t wh_sz, int flpi, value prev, - value cur) +static header_t *nf_allocate_block (mlsize_t wh_sz, value prev, value cur) { header_t h = Hd_bp (cur); CAMLassert (Whsize_hd (h) >= wh_sz); if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ caml_fl_cur_wsz -= Whsize_hd (h); - Next (prev) = Next (cur); - CAMLassert (Is_in_heap (Next (prev)) || Next (prev) == Val_NULL); + Next_small (prev) = Next_small (cur); + CAMLassert (Is_in_heap (Next_small (prev)) + || Next_small (prev) == Val_NULL); if (caml_fl_merge == cur) caml_fl_merge = prev; #ifdef DEBUG - fl_last = Val_NULL; + nf_last = Val_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. */ + calling [nf_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) ? Val_NULL : prev; - -- flp_size; - } - } }else{ /* Case 2. */ caml_fl_cur_wsz -= wh_sz; Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); } - if (policy == Policy_next_fit) fl_prev = prev; + nf_prev = prev; return (header_t *) &Field (cur, Wosize_hd (h) - wh_sz); } -#ifdef CAML_INSTR -static uintnat instr_size [20] = - {0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0}; -static char *instr_name [20] = { - NULL, - "alloc01@", - "alloc02@", - "alloc03@", - "alloc04@", - "alloc05@", - "alloc06@", - "alloc07@", - "alloc08@", - "alloc09@", - "alloc10-19@", - "alloc20-29@", - "alloc30-39@", - "alloc40-49@", - "alloc50-59@", - "alloc60-69@", - "alloc70-79@", - "alloc80-89@", - "alloc90-99@", - "alloc_large@", -}; -uintnat caml_instr_alloc_jump = 0; -/* number of pointers followed to allocate from the free list */ -#endif /*CAML_INSTR*/ - -/* [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. -*/ -header_t *caml_fl_allocate (mlsize_t wo_sz) +static header_t *nf_allocate (mlsize_t wo_sz) { value cur = Val_NULL, prev; - header_t *result; - int i; - mlsize_t sz, prevsz; CAMLassert (sizeof (char *) == sizeof (value)); CAMLassert (wo_sz >= 1); #ifdef CAML_INSTR @@ -204,68 +189,359 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) } #endif /* CAML_INSTR */ - switch (policy){ - case Policy_next_fit: - CAMLassert (fl_prev != Val_NULL); - /* Search from [fl_prev] to the end of the list. */ - prev = fl_prev; - cur = Next (prev); + CAMLassert (nf_prev != Val_NULL); + /* Search from [nf_prev] to the end of the list. */ + prev = nf_prev; + cur = Next_small (prev); while (cur != Val_NULL){ CAMLassert (Is_in_heap (cur)); if (Wosize_bp (cur) >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); + return nf_allocate_block (Whsize_wosize (wo_sz), prev, cur); } prev = cur; - cur = Next (prev); + cur = Next_small (prev); #ifdef CAML_INSTR ++ caml_instr_alloc_jump; #endif } - fl_last = prev; - /* Search from the start of the list to [fl_prev]. */ - prev = Fl_head; - cur = Next (prev); - while (prev != fl_prev){ + nf_last = prev; + /* Search from the start of the list to [nf_prev]. */ + prev = Nf_head; + cur = Next_small (prev); + while (prev != nf_prev){ if (Wosize_bp (cur) >= wo_sz){ - return allocate_block (Whsize_wosize (wo_sz), 0, prev, cur); + return nf_allocate_block (Whsize_wosize (wo_sz), prev, cur); } prev = cur; - cur = Next (prev); + cur = Next_small (prev); #ifdef CAML_INSTR ++ caml_instr_alloc_jump; #endif } /* No suitable block was found. */ return NULL; - break; +} + +/* Location of the last fragment seen by the sweeping code. + This is a pointer to the first word after the fragment, which is + the header of the next block. + Note that [last_fragment] doesn't point to the fragment itself, + but to the block after it. +*/ +static header_t *nf_last_fragment; + +static void nf_init_merge (void) +{ +#ifdef CAML_INSTR + int i; + for (i = 1; i < 20; i++){ + CAML_INSTR_INT (instr_name[i], instr_size[i]); + instr_size[i] = 0; + } +#endif /* CAML_INSTR */ + nf_last_fragment = NULL; + caml_fl_merge = Nf_head; +#ifdef DEBUG + nf_check (); +#endif +} + +static void nf_reset (void) +{ + Next_small (Nf_head) = Val_NULL; + nf_prev = Nf_head; + caml_fl_cur_wsz = 0; + nf_init_merge (); +} + +/* Note: the [limit] parameter is unused because we merge blocks one by one. */ +static header_t *nf_merge_block (value bp, char *limit) +{ + value prev, cur, adj; + header_t hd = Hd_val (bp); + mlsize_t prev_wosz; + + caml_fl_cur_wsz += Whsize_hd (hd); + + /* [merge_block] is now responsible for calling the finalization function. */ + if (Tag_hd (hd) == Custom_tag){ + void (*final_fun)(value) = Custom_ops_val(bp)->finalize; + if (final_fun != NULL) final_fun(bp); + } + +#ifdef DEBUG + caml_set_fields (bp, 0, Debug_free_major); +#endif + prev = caml_fl_merge; + cur = Next_small (prev); + /* The sweep code makes sure that this is the right place to insert + this block: */ + CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Nf_head); + CAMLassert (Bp_val (cur) > Bp_val (bp) || cur == Val_NULL); + + /* If [last_fragment] and [bp] are adjacent, merge them. */ + if (nf_last_fragment == Hp_val (bp)){ + mlsize_t bp_whsz = Whsize_val (bp); + if (bp_whsz <= Max_wosize){ + hd = Make_header (bp_whsz, 0, Caml_white); + bp = (value) nf_last_fragment; + Hd_val (bp) = hd; + caml_fl_cur_wsz += Whsize_wosize (0); + } + } + + /* If [bp] and [cur] are adjacent, remove [cur] from the free-list + and merge them. */ + adj = Next_in_mem (bp); + if (adj == cur){ + value next_cur = Next_small (cur); + mlsize_t cur_whsz = Whsize_val (cur); + + if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ + Next_small (prev) = next_cur; + if (nf_prev == cur) nf_prev = prev; + hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); + Hd_val (bp) = hd; + adj = Next_in_mem (bp); +#ifdef DEBUG + nf_last = Val_NULL; + Next_small (cur) = (value) Debug_free_major; + Hd_val (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_val (prev); + if (Next_in_mem (prev) == bp && prev_wosz + Whsize_hd (hd) < Max_wosize){ + Hd_val (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0, Caml_blue); +#ifdef DEBUG + Hd_val (bp) = Debug_free_major; +#endif + CAMLassert (caml_fl_merge == prev); + }else if (Wosize_hd (hd) != 0){ + Hd_val (bp) = Bluehd_hd (hd); + Next_small (bp) = cur; + Next_small (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. */ + nf_last_fragment = (header_t *) bp; + caml_fl_cur_wsz -= Whsize_wosize (0); + } + return Hp_val (adj); +} + +/* This is a heap extension. We have to insert it in the right place + in the free-list. + [nf_add_blocks] can only be called right after a call to + [nf_allocate] that returned Val_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 Val_NULL, and field 1 of the first block must point to + the last block. +*/ +static void nf_add_blocks (value bp) +{ + value cur = bp; + CAMLassert (nf_last != Val_NULL); + CAMLassert (Next_small (nf_last) == Val_NULL); + do { + caml_fl_cur_wsz += Whsize_bp (cur); + cur = Field(cur, 0); + } while (cur != Val_NULL); + + if (Bp_val (bp) > Bp_val (nf_last)){ + Next_small (nf_last) = bp; + if (nf_last == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ + caml_fl_merge = Field (bp, 1); + } + }else{ + value prev; + + prev = Nf_head; + cur = Next_small (prev); + while (cur != Val_NULL && Bp_val (cur) < Bp_val (bp)){ + CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Nf_head); + prev = cur; + cur = Next_small (prev); + } + CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Nf_head); + CAMLassert (Bp_val (cur) > Bp_val (bp) || cur == Val_NULL); + Next_small (Field (bp, 1)) = cur; + Next_small (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 && (char *) bp < caml_gc_sweep_hp){ + caml_fl_merge = Field (bp, 1); + } + } +} + +static void nf_make_free_blocks + (value *p, mlsize_t size, int do_merge, int color) +{ + mlsize_t sz; + + while (size > 0){ + if (size > Whsize_wosize (Max_wosize)){ + sz = Whsize_wosize (Max_wosize); + }else{ + sz = size; + } + *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color); + if (do_merge) nf_merge_block (Val_hp (p), NULL); + size -= sz; + p += sz; + } +} + +/******************** first-fit allocation policy *********************/ + +#define FLP_MAX 1000 +static value flp [FLP_MAX]; +static int flp_size = 0; +static value beyond = Val_NULL; + +/* The sentinel can be located anywhere in memory, but it must not be + adjacent to any heap object. */ +static struct { + value filler1; /* Make sure the sentinel is never adjacent to any block. */ + header_t h; + value first_field; + value filler2; /* Make sure the sentinel is never adjacent to any block. */ +} ff_sentinel = {0, Make_header (0, 0, Caml_blue), Val_NULL, 0}; + +#define Ff_head (Val_bp (&(ff_sentinel.first_field))) +static value ff_last = Val_NULL; /* Last block in the list. Only valid + just after [ff_allocate] returns NULL. */ + + +#if defined (DEBUG) || FREELIST_DEBUG +static void ff_check (void) +{ + value cur; + int flp_found = 0, merge_found = 0; + uintnat size_found = 0; + int sz = 0; + + cur = Next_small (Ff_head); + while (cur != Val_NULL){ + size_found += Whsize_bp (cur); + CAMLassert (Is_in_heap (cur)); + if (Wosize_bp (cur) > sz){ + sz = Wosize_bp (cur); + if (flp_found < flp_size){ + CAMLassert (Next_small (flp[flp_found]) == cur); + ++ flp_found; + }else{ + CAMLassert (beyond == Val_NULL + || Bp_val (cur) >= Bp_val (Next_small (beyond))); + } + } + if (cur == caml_fl_merge) merge_found = 1; + cur = Next_small (cur); + } + CAMLassert (flp_found == flp_size); + CAMLassert (merge_found || caml_fl_merge == Ff_head); + CAMLassert (size_found == caml_fl_cur_wsz); +} +#endif /* DEBUG || FREELIST_DEBUG */ + +/* [ff_allocate_block] is called by [ff_allocate]. Given a suitable free + block and the requested size, it allocates a new block from the free + block. There are three cases: + 0. The free block has the requested size. Detach the block from the + free-list and return it. + 1. The free block is 1 word longer than the requested 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 large 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, so that + the linking of the free-list does not change in case 2. +*/ +static header_t *ff_allocate_block (mlsize_t wh_sz, int flpi, value prev, + value cur) +{ + header_t h = Hd_bp (cur); + CAMLassert (Whsize_hd (h) >= wh_sz); + if (Wosize_hd (h) < wh_sz + 1){ /* Cases 0 and 1. */ + caml_fl_cur_wsz -= Whsize_hd (h); + Next_small (prev) = Next_small (cur); + CAMLassert (Is_in_heap (Next_small (prev)) + || Next_small (prev) == Val_NULL); + if (caml_fl_merge == cur) caml_fl_merge = prev; +#ifdef DEBUG + ff_last = Val_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 [ff_allocate] will overwrite it. */ + Hd_op (cur) = Make_header (0, 0, Caml_white); + if (flpi + 1 < flp_size && flp[flpi + 1] == cur){ + flp[flpi + 1] = prev; + }else if (flpi == flp_size - 1){ + beyond = (prev == Ff_head) ? Val_NULL : prev; + -- flp_size; + } + }else{ /* Case 2. */ + caml_fl_cur_wsz -= wh_sz; + Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue); + } + return (header_t *) &Field (cur, Wosize_hd (h) - wh_sz); +} + +static header_t *ff_allocate (mlsize_t wo_sz) +{ + value cur = Val_NULL, prev; + header_t *result; + int i; + mlsize_t sz, prevsz; + CAMLassert (sizeof (char *) == sizeof (value)); + CAMLassert (wo_sz >= 1); +#ifdef CAML_INSTR + if (wo_sz < 10){ + ++instr_size[wo_sz]; + }else if (wo_sz < 100){ + ++instr_size[wo_sz/10 + 9]; + }else{ + ++instr_size[19]; + } +#endif /* CAML_INSTR */ - case Policy_first_fit: { /* Search in the flp array. */ for (i = 0; i < flp_size; i++){ - sz = Wosize_bp (Next (flp[i])); + sz = Wosize_bp (Next_small (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])); + result = ff_allocate_block (Whsize_wosize (wo_sz), i, flp[i], + Next_small (flp[i])); goto update_flp; } } /* Extend the flp array. */ if (flp_size == 0){ - prev = Fl_head; + prev = Ff_head; prevsz = 0; }else{ - prev = Next (flp[flp_size - 1]); + prev = Next_small (flp[flp_size - 1]); prevsz = Wosize_bp (prev); if (beyond != Val_NULL) prev = beyond; } while (flp_size < FLP_MAX){ - cur = Next (prev); + cur = Next_small (prev); if (cur == Val_NULL){ - fl_last = prev; - beyond = (prev == Fl_head) ? Val_NULL : prev; + ff_last = prev; + beyond = (prev == Ff_head) ? Val_NULL : prev; return NULL; }else{ sz = Wosize_bp (cur); @@ -280,8 +556,8 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) fprintf (stderr, "FLP: extended to %d\n", flp_size); } #endif - result = allocate_block (Whsize_wosize (wo_sz), flp_size - 1, prev, - cur); + result = ff_allocate_block (Whsize_wosize (wo_sz), flp_size - 1, + prev, cur); goto update_flp; } prevsz = sz; @@ -300,21 +576,21 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) }else{ prev = flp[flp_size - 1]; } - prevsz = Wosize_bp (Next (flp[FLP_MAX-1])); + prevsz = Wosize_bp (Next_small (flp[FLP_MAX-1])); CAMLassert (prevsz < wo_sz); - cur = Next (prev); + cur = Next_small (prev); while (cur != Val_NULL){ CAMLassert (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); + return ff_allocate_block (Whsize_wosize (wo_sz), flp_size, prev, cur); } prev = cur; - cur = Next (prev); + cur = Next_small (prev); } - fl_last = prev; + ff_last = prev; return NULL; update_flp: /* (i, sz) */ @@ -322,13 +598,13 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) CAMLassert (0 <= i && i < flp_size + 1); if (i < flp_size){ if (i > 0){ - prevsz = Wosize_bp (Next (flp[i-1])); + prevsz = Wosize_bp (Next_small (flp[i-1])); }else{ prevsz = 0; } if (i == flp_size - 1){ - if (Wosize_bp (Next (flp[i])) <= prevsz){ - beyond = Next (flp[i]); + if (Wosize_bp (Next_small (flp[i])) <= prevsz){ + beyond = Next_small (flp[i]); -- flp_size; }else{ beyond = Val_NULL; @@ -340,7 +616,7 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) prev = flp[i]; while (prev != flp[i+1] && j < FLP_MAX - i){ - cur = Next (prev); + cur = Next_small (prev); sz = Wosize_bp (cur); if (sz > prevsz){ buf[j++] = prev; @@ -373,30 +649,22 @@ header_t *caml_fl_allocate (mlsize_t wo_sz) } } flp_size = FLP_MAX - 1; - beyond = Next (flp[FLP_MAX - 1]); + beyond = Next_small (flp[FLP_MAX - 1]); } } } return result; - } - break; - - default: - CAMLassert (0); /* unknown policy */ - break; - } - return NULL; /* NOT REACHED */ } /* Location of the last fragment seen by the sweeping code. This is a pointer to the first word after the fragment, which is the header of the next block. - Note that [last_fragment] doesn't point to the fragment itself, + Note that [ff_last_fragment] doesn't point to the fragment itself, but to the block after it. */ -static header_t *last_fragment; +static header_t *ff_last_fragment; -void caml_fl_init_merge (void) +static void ff_init_merge (void) { #ifdef CAML_INSTR int i; @@ -405,74 +673,67 @@ void caml_fl_init_merge (void) instr_size[i] = 0; } #endif /* CAML_INSTR */ - last_fragment = NULL; - caml_fl_merge = Fl_head; + ff_last_fragment = NULL; + caml_fl_merge = Ff_head; #ifdef DEBUG - fl_check (); + ff_check (); #endif } -static void truncate_flp (value changed) +static void ff_truncate_flp (value changed) { - if (changed == Fl_head){ + if (changed == Ff_head){ flp_size = 0; beyond = Val_NULL; }else{ - while (flp_size > 0 - && Bp_val (Next (flp[flp_size - 1])) >= Bp_val (changed)) + while (flp_size > 0 && + Bp_val (Next_small (flp[flp_size - 1])) >= Bp_val (changed)) -- flp_size; if (Bp_val (beyond) >= Bp_val (changed)) beyond = Val_NULL; } } -/* This is called by caml_compact_heap. */ -void caml_fl_reset (void) +static void ff_reset (void) { - Next (Fl_head) = Val_NULL; - switch (policy){ - case Policy_next_fit: - fl_prev = Fl_head; - break; - case Policy_first_fit: - truncate_flp (Fl_head); - break; - default: - CAMLassert (0); - break; - } + Next_small (Ff_head) = Val_NULL; + ff_truncate_flp (Ff_head); caml_fl_cur_wsz = 0; - caml_fl_init_merge (); + ff_init_merge (); } -/* [caml_fl_merge_block] returns the head pointer of the next block after [bp], - because merging blocks may change the size of [bp]. */ -header_t *caml_fl_merge_block (value bp) +/* Note: the [limit] parameter is unused because we merge blocks one by one. */ +header_t *ff_merge_block (value bp, char *limit) { - value prev, cur; - header_t *adj; + value prev, cur, adj; header_t hd = Hd_val (bp); mlsize_t prev_wosz; caml_fl_cur_wsz += Whsize_hd (hd); + /* [merge_block] is now responsible for calling the finalization function. */ + if (Tag_hd (hd) == Custom_tag){ + void (*final_fun)(value) = Custom_ops_val(bp)->finalize; + if (final_fun != NULL) final_fun(bp); + } + #ifdef DEBUG caml_set_fields (bp, 0, Debug_free_major); #endif prev = caml_fl_merge; - cur = Next (prev); + cur = Next_small (prev); /* The sweep code makes sure that this is the right place to insert this block: */ - CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Fl_head); + CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Ff_head); CAMLassert (Bp_val (cur) > Bp_val (bp) || cur == Val_NULL); - if (policy == Policy_first_fit) truncate_flp (prev); + ff_truncate_flp (prev); - /* If [last_fragment] and [bp] are adjacent, merge them. */ - if (last_fragment == Hp_val (bp)){ + /* If [ff_last_fragment] and [bp] are adjacent, merge them. */ + if (ff_last_fragment == Hp_bp (bp)){ mlsize_t bp_whsz = Whsize_val (bp); if (bp_whsz <= Max_wosize){ hd = Make_header (bp_whsz, 0, Caml_white); - bp = (value) last_fragment; + bp = (value) ff_last_fragment; Hd_val (bp) = hd; caml_fl_cur_wsz += Whsize_wosize (0); } @@ -480,20 +741,19 @@ header_t *caml_fl_merge_block (value bp) /* If [bp] and [cur] are adjacent, remove [cur] from the free-list and merge them. */ - adj = (header_t *) &Field (bp, Wosize_hd (hd)); - if (adj == Hp_val (cur)){ - value next_cur = Next (cur); + adj = Next_in_mem (bp); + if (adj == cur){ + value next_cur = Next_small (cur); mlsize_t cur_whsz = Whsize_val (cur); if (Wosize_hd (hd) + cur_whsz <= Max_wosize){ - Next (prev) = next_cur; - if (policy == Policy_next_fit && fl_prev == cur) fl_prev = prev; + Next_small (prev) = next_cur; hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue); Hd_val (bp) = hd; - adj = (header_t *) &Field (bp, Wosize_hd (hd)); + adj = Next_in_mem (bp); #ifdef DEBUG - fl_last = Val_NULL; - Next (cur) = (value) Debug_free_major; + ff_last = Val_NULL; + Next_small (cur) = (value) Debug_free_major; Hd_val (cur) = Debug_free_major; #endif cur = next_cur; @@ -502,31 +762,30 @@ header_t *caml_fl_merge_block (value bp) /* If [prev] and [bp] are adjacent merge them, else insert [bp] into the free-list if it is big enough. */ prev_wosz = Wosize_val (prev); - if ((header_t *) &Field (prev, prev_wosz) == Hp_val (bp) - && prev_wosz + Whsize_hd (hd) < Max_wosize){ - Hd_val (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue); + if (Next_in_mem (prev) == bp && prev_wosz + Whsize_hd (hd) < Max_wosize){ + Hd_val (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0, Caml_blue); #ifdef DEBUG Hd_val (bp) = Debug_free_major; #endif CAMLassert (caml_fl_merge == prev); }else if (Wosize_hd (hd) != 0){ Hd_val (bp) = Bluehd_hd (hd); - Next (bp) = cur; - Next (prev) = bp; + Next_small (bp) = cur; + Next_small (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 = (header_t *) bp; + ff_last_fragment = (header_t *) bp; caml_fl_cur_wsz -= Whsize_wosize (0); } - return adj; + return Hp_val (adj); } /* 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 Val_NULL. + [ff_add_blocks] can only be called right after a call to + [ff_allocate] that returned Val_NULL. Most of the heap extensions are expected to be at the end of the free list. (This depends on the implementation of [malloc].) @@ -534,60 +793,51 @@ header_t *caml_fl_merge_block (value bp) terminated by Val_NULL, and field 1 of the first block must point to the last block. */ -void caml_fl_add_blocks (value bp) +static void ff_add_blocks (value bp) { value cur = bp; - CAMLassert (fl_last != Val_NULL); - CAMLassert (Next (fl_last) == Val_NULL); + CAMLassert (ff_last != Val_NULL); + CAMLassert (Next_small (ff_last) == Val_NULL); do { caml_fl_cur_wsz += Whsize_bp (cur); cur = Field(cur, 0); } while (cur != Val_NULL); - if (Bp_val (bp) > Bp_val (fl_last)){ - Next (fl_last) = bp; - if (fl_last == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ + if (Bp_val (bp) > Bp_val (ff_last)){ + Next_small (ff_last) = bp; + if (ff_last == caml_fl_merge && (char *) bp < caml_gc_sweep_hp){ caml_fl_merge = Field (bp, 1); } - if (policy == Policy_first_fit && flp_size < FLP_MAX){ - flp [flp_size++] = fl_last; + if (flp_size < FLP_MAX){ + flp [flp_size++] = ff_last; } }else{ value prev; - prev = Fl_head; - cur = Next (prev); + prev = Ff_head; + cur = Next_small (prev); while (cur != Val_NULL && Bp_val (cur) < Bp_val (bp)){ - CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Fl_head); + CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Ff_head); /* XXX TODO: extend flp on the fly */ prev = cur; - cur = Next (prev); + cur = Next_small (prev); } - CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Fl_head); + CAMLassert (Bp_val (prev) < Bp_val (bp) || prev == Ff_head); CAMLassert (Bp_val (cur) > Bp_val (bp) || cur == Val_NULL); - Next (Field (bp, 1)) = cur; - Next (prev) = bp; + Next_small (Field (bp, 1)) = cur; + Next_small (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 && (char *) bp < caml_gc_sweep_hp){ caml_fl_merge = Field (bp, 1); } - if (policy == Policy_first_fit) truncate_flp (bp); + ff_truncate_flp (bp); } } -/* Cut a block of memory into Max_wosize pieces, give them headers, - and optionally merge them into the free list. - arguments: - p: pointer to the first word of the block - size: size of the block (in words) - do_merge: 1 -> do merge; 0 -> do not merge - color: which color to give to the pieces; if [do_merge] is 1, this - is overridden by the merge code, but we have historically used - [Caml_white]. -*/ -void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color) +static void ff_make_free_blocks + (value *p, mlsize_t size, int do_merge, int color) { mlsize_t sz; @@ -597,27 +847,1040 @@ void caml_make_free_blocks (value *p, mlsize_t size, int do_merge, int color) }else{ sz = size; } - *(header_t *)p = - Make_header (Wosize_whsize (sz), 0, color); - if (do_merge) caml_fl_merge_block (Val_hp (p)); + *(header_t *)p = Make_header (Wosize_whsize (sz), 0, color); + if (do_merge) ff_merge_block (Val_hp (p), NULL); + size -= sz; + p += sz; + } +} + +/********************* best-fit allocation policy *********************/ + +/* quick-fit + FIFO-ordered best fit (Wilson's nomenclature) + We use Standish's data structure (a tree of doubly-linked lists) + with a splay tree (Sleator & Tarjan). +*/ + +/* [BF_NUM_SMALL] must be at least 4 for this code to work + and at least 5 for good performance on typical OCaml programs. + For portability reasons, BF_NUM_SMALL cannot be more than 32. +*/ +#define BF_NUM_SMALL 16 + +/* Note that indexing into [bf_small_fl] starts at 1, so the first entry + in this array is unused. +*/ +static struct { + value free; + value *merge; +} bf_small_fl [BF_NUM_SMALL + 1]; +static int bf_small_map = 0; + +/* Small free blocks have only one pointer to the next block. + Large free blocks have 5 fields: + tree fields: + - node flag + - left son + - right son + list fields: + - next + - prev +*/ +typedef struct large_free_block { + int isnode; + struct large_free_block *left; + struct large_free_block *right; + struct large_free_block *prev; + struct large_free_block *next; +} large_free_block; + +static inline mlsize_t bf_large_wosize (struct large_free_block *n) { + return Wosize_val((value)(n)); +} + +static struct large_free_block *bf_large_tree; +static struct large_free_block *bf_large_least; +/* [bf_large_least] is either NULL or a pointer to the smallest (leftmost) + block in the tree. In this latter case, the block must be alone in its + doubly-linked list (i.e. have [isnode] true and [prev] and [next] + both pointing back to this block) +*/ + +/* Auxiliary functions for bitmap */ + +/* Find first (i.e. least significant) bit set in a word. */ +#ifdef HAS_FFS +/* Nothing to do */ +#elif defined(HAS_BITSCANFORWARD) +#include <intrin.h> +static inline int ffs (int x) +{ + unsigned long index; + unsigned char result; + result = _BitScanForward (&index, (unsigned long) x); + return result ? (int) index + 1 : 0; +} +#else +static inline int ffs (int x) +{ + /* adapted from Hacker's Delight */ + int result, bnz, b0, b1, b2, b3, b4; + CAMLassert ((x & 0xFFFFFFFF) == x); + x = x & -x; + bnz = x != 0; + b4 = !!(x & 0xFFFF0000) << 4; + b3 = !!(x & 0xFF00FF00) << 3; + b2 = !!(x & 0xF0F0F0F0) << 2; + b1 = !!(x & 0xCCCCCCCC) << 1; + b0 = !!(x & 0xAAAAAAAA); + return bnz + b0 + b1 + b2 + b3 + b4; +} +#endif /* HAS_FFS or HAS_BITSCANFORWARD */ + +/* Indexing starts at 1 because that's the minimum block size. */ +static inline void set_map (int index) +{ + bf_small_map |= (1 << (index - 1)); +} +static inline void unset_map (int index) +{ + bf_small_map &= ~(1 << (index - 1)); +} + + +/* debug functions for checking the data structures */ + +#if defined (DEBUG) || FREELIST_DEBUG + +static mlsize_t bf_check_cur_size = 0; +static asize_t bf_check_subtree (large_free_block *p) +{ + mlsize_t wosz; + large_free_block *cur, *next; + asize_t total_size = 0; + + if (p == NULL) return 0; + + wosz = bf_large_wosize(p); + CAMLassert (p->isnode == 1); + total_size += bf_check_subtree (p->left); + CAMLassert (wosz > BF_NUM_SMALL); + CAMLassert (wosz > bf_check_cur_size); + bf_check_cur_size = wosz; + cur = p; + while (1){ + CAMLassert (bf_large_wosize (cur) == wosz); + CAMLassert (Color_val ((value) cur) == Caml_blue); + CAMLassert ((cur == p && cur->isnode == 1) || cur->isnode == 0); + total_size += Whsize_wosize (wosz); + next = cur->next; + CAMLassert (next->prev == cur); + if (next == p) break; + cur = next; + } + total_size += bf_check_subtree (p->right); + return total_size; +} + +static void bf_check (void) +{ + mlsize_t i; + asize_t total_size = 0; + int map = 0; + + /* check free lists */ + CAMLassert (BF_NUM_SMALL <= 8 * sizeof (int)); + for (i = 1; i <= BF_NUM_SMALL; i++){ + value b; + int col = 0; + int merge_found = 0; + + if (bf_small_fl[i].merge == &bf_small_fl[i].free){ + merge_found = 1; + }else{ + CAMLassert (caml_gc_phase != Phase_sweep + || caml_fl_merge == Val_NULL + || Val_bp (bf_small_fl[i].merge) < caml_fl_merge); + } + CAMLassert (*bf_small_fl[i].merge == Val_NULL + || Color_val (*bf_small_fl[i].merge) == Caml_blue); + if (bf_small_fl[i].free != Val_NULL) map |= 1 << (i-1); + for (b = bf_small_fl[i].free; b != Val_NULL; b = Next_small (b)){ + if (bf_small_fl[i].merge == &Next_small (b)) merge_found = 1; + CAMLassert (Wosize_val (b) == i); + total_size += Whsize_wosize (i); + if (Color_val (b) == Caml_blue){ + col = 1; + CAMLassert (Next_small (b) == Val_NULL + || Bp_val (Next_small (b)) > Bp_val (b)); + }else{ + CAMLassert (col == 0); + CAMLassert (Color_val (b) == Caml_white); + } + } + if (caml_gc_phase == Phase_sweep) CAMLassert (merge_found); + } + CAMLassert (map == bf_small_map); + /* check [caml_fl_merge] */ + CAMLassert (caml_gc_phase != Phase_sweep + || caml_fl_merge == Val_NULL + || Hp_val (caml_fl_merge) < (header_t *) caml_gc_sweep_hp); + /* check the tree */ + bf_check_cur_size = 0; + total_size += bf_check_subtree (bf_large_tree); + /* check the total free set size */ + CAMLassert (total_size == caml_fl_cur_wsz); + /* check the smallest-block pointer */ + if (bf_large_least != NULL){ + large_free_block *x = bf_large_tree; + while (x->left != NULL) x = x->left; + CAMLassert (x == bf_large_least); + CAMLassert (x->isnode == 1); + CAMLassert (x->prev == x); + CAMLassert (x->next == x); + } +} + +#endif /* DEBUG || FREELIST_DEBUG */ + +#if FREELIST_DEBUG +#define FREELIST_DEBUG_bf_check() bf_check () +#else +#define FREELIST_DEBUG_bf_check() +#endif + +/**************************************************************************/ +/* splay trees */ + +/* Our tree is composed of nodes. Each node is the head of a doubly-linked + circular list of blocks, all of the same size. +*/ + +/* Search for the node of the given size. Return a pointer to the pointer + to the node, or a pointer to the NULL where the node should have been + (it can be inserted here). +*/ +static large_free_block **bf_search (mlsize_t wosz) +{ + large_free_block **p = &bf_large_tree; + large_free_block *cur; + mlsize_t cursz; + + while (1){ + cur = *p; + INSTR_alloc_jump (1); + if (cur == NULL) break; + cursz = bf_large_wosize (cur); + if (cursz == wosz){ + break; + }else if (cursz > wosz){ + p = &(cur->left); + }else{ + CAMLassert (cursz < wosz); + p = &(cur->right); + } + } + return p; +} + +/* Search for the least node that is large enough to accomodate the given + size. Return in [next_lower] an upper bound on either the size of the + next-lower node in the tree, or BF_NUM_SMALL if there is no such node. +*/ +static large_free_block **bf_search_best (mlsize_t wosz, mlsize_t *next_lower) +{ + large_free_block **p = &bf_large_tree; + large_free_block **best = NULL; + mlsize_t lowsz = BF_NUM_SMALL; + large_free_block *cur; + mlsize_t cursz; + + while (1){ + cur = *p; + INSTR_alloc_jump (1); + if (cur == NULL){ + *next_lower = lowsz; + break; + } + cursz = bf_large_wosize (cur); + if (cursz == wosz){ + best = p; + *next_lower = wosz; + break; + }else if (cursz > wosz){ + best = p; + p = &(cur->left); + }else{ + CAMLassert (cursz < wosz); + lowsz = cursz; + p = &(cur->right); + } + } + return best; +} + +/* Splay the tree at the given size. If a node of this size exists, it will + become the root. If not, the last visited node will be the root. This is + either the least node larger or the greatest node smaller than the given + size. + We use simple top-down splaying as described in S&T 85. +*/ +static void bf_splay (mlsize_t wosz) +{ + large_free_block *x, *y; + mlsize_t xsz; + large_free_block *left_top = NULL; + large_free_block *right_top = NULL; + large_free_block **left_bottom = &left_top; + large_free_block **right_bottom = &right_top; + + x = bf_large_tree; + if (x == NULL) return; + while (1){ + xsz = bf_large_wosize (x); + if (xsz == wosz) break; + if (xsz > wosz){ + /* zig */ + y = x->left; + INSTR_alloc_jump (1); + if (y == NULL) break; + if (bf_large_wosize (y) > wosz){ + /* zig-zig: rotate right */ + x->left = y->right; + y->right = x; + x = y; + y = x->left; + INSTR_alloc_jump (2); + if (y == NULL) break; + } + /* link right */ + *right_bottom = x; + right_bottom = &(x->left); + x = y; + }else{ + CAMLassert (xsz < wosz); + /* zag */ + y = x->right; + INSTR_alloc_jump (1); + if (y == NULL) break; + if (bf_large_wosize (y) < wosz){ + /* zag-zag : rotate left */ + x->right = y->left; + y->left = x; + x = y; + y = x->right; + INSTR_alloc_jump (2); + if (y == NULL) break; + } + /* link left */ + *left_bottom = x; + left_bottom = &(x->right); + x = y; + } + } + /* reassemble the tree */ + *left_bottom = x->left; + *right_bottom = x->right; + x->left = left_top; + x->right = right_top; + INSTR_alloc_jump (2); + bf_large_tree = x; +} + +/* Splay the subtree at [p] on its leftmost (least) node. After this + operation, the root node of the subtree is the least node and it + has no left child. + The subtree must not be empty. +*/ +static void bf_splay_least (large_free_block **p) +{ + large_free_block *x, *y; + large_free_block *right_top = NULL; + large_free_block **right_bottom = &right_top; + + x = *p; + INSTR_alloc_jump (1); + CAMLassert (x != NULL); + while (1){ + /* We are always in the zig case. */ + y = x->left; + INSTR_alloc_jump (1); + if (y == NULL) break; + /* And in the zig-zig case. rotate right */ + x->left = y->right; + y->right = x; + x = y; + y = x->left; + INSTR_alloc_jump (2); + if (y == NULL) break; + /* link right */ + *right_bottom = x; + right_bottom = &(x->left); + x = y; + } + /* reassemble the tree */ + CAMLassert (x->left == NULL); + *right_bottom = x->right; + INSTR_alloc_jump (1); + x->right = right_top; + *p = x; +} + +/* Remove the node at [p], if any. */ +static void bf_remove_node (large_free_block **p) +{ + large_free_block *x; + large_free_block *l, *r; + + x = *p; + INSTR_alloc_jump (1); + if (x == NULL) return; + if (x == bf_large_least) bf_large_least = NULL; + l = x->left; + r = x->right; + INSTR_alloc_jump (2); + if (l == NULL){ + *p = r; + }else if (r == NULL){ + *p = l; + }else{ + bf_splay_least (&r); + r->left = l; + *p = r; + } +} + +/* Insert a block into the tree, either as a new node or as a block in an + existing list. + Splay if the list is already present. +*/ +static void bf_insert_block (large_free_block *n) +{ + mlsize_t sz = bf_large_wosize (n); + large_free_block **p = bf_search (sz); + large_free_block *x = *p; + INSTR_alloc_jump (1); + + if (bf_large_least != NULL){ + mlsize_t least_sz = bf_large_wosize (bf_large_least); + if (sz < least_sz){ + CAMLassert (x == NULL); + bf_large_least = n; + }else if (sz == least_sz){ + CAMLassert (x == bf_large_least); + bf_large_least = NULL; + } + } + + CAMLassert (Color_val ((value) n) == Caml_blue); + CAMLassert (Wosize_val ((value) n) > BF_NUM_SMALL); + if (x == NULL){ + /* add new node */ + n->isnode = 1; + n->left = n->right = NULL; + n->prev = n->next = n; + *p = n; + }else{ + /* insert at tail of doubly-linked list */ + CAMLassert (x->isnode == 1); + n->isnode = 0; +#ifdef DEBUG + n->left = n->right = (large_free_block *) Debug_free_unused; +#endif + n->prev = x->prev; + n->next = x; + x->prev->next = n; + x->prev = n; + INSTR_alloc_jump (2); + bf_splay (sz); + } +} + +#if defined (DEBUG) || FREELIST_DEBUG +static int bf_is_in_tree (large_free_block *b) +{ + int wosz = bf_large_wosize (b); + large_free_block **p = bf_search (wosz); + large_free_block *n = *p; + large_free_block *cur = n; + + if (n == NULL) return 0; + while (1){ + if (cur == b) return 1; + cur = cur->next; + if (cur == n) return 0; + } +} +#endif /* DEBUG || FREELIST_DEBUG */ + +/**************************************************************************/ + +/* Add back a remnant into a small free list. The block must be small + and white (or a 0-size fragment). + The block may be left out of the list depending on the sweeper's state. + The free list size is updated accordingly. + + The block will be left out of the list if the GC is in its Sweep phase + and the block is in the still-to-be-swept region because every block of + the free list encountered by the sweeper must be blue and linked in + its proper place in the increasing-addresses order of the list. This is + to ensure that coalescing is always done when two or more free blocks + are adjacent. +*/ +static void bf_insert_remnant_small (value v) +{ + mlsize_t wosz = Wosize_val (v); + + CAMLassert (Color_val (v) == Caml_white); + CAMLassert (wosz <= BF_NUM_SMALL); + if (wosz != 0 + && (caml_gc_phase != Phase_sweep + || (char *) Hp_val (v) < (char *) caml_gc_sweep_hp)){ + caml_fl_cur_wsz += Whsize_wosize (wosz); + Next_small (v) = bf_small_fl[wosz].free; + bf_small_fl[wosz].free = v; + if (bf_small_fl[wosz].merge == &bf_small_fl[wosz].free){ + bf_small_fl[wosz].merge = &Next_small (v); + } + set_map (wosz); + } +} + +/* Add back a remnant into the free set. The block must have the + appropriate color: + - White if it is a fragment or a small block (wosize <= BF_NUM_SMALL) + - Blue if it is a large block (BF_NUM_SMALL < wosize) + The block may be left out or the set, depending on its size and the + sweeper's state. + The free list size is updated accordingly. +*/ +static void bf_insert_remnant (value v) +{ + mlsize_t wosz = Wosize_val (v); + + if (wosz <= BF_NUM_SMALL){ + CAMLassert (Color_val (v) == Caml_white); + bf_insert_remnant_small (v); + }else{ + CAMLassert (Color_val (v) == Caml_blue); + bf_insert_block ((large_free_block *) v); + caml_fl_cur_wsz += Whsize_wosize (wosz); + } +} +/* Insert the block into the free set during sweep. The block must be blue. */ +static void bf_insert_sweep (value v) +{ + mlsize_t wosz = Wosize_val (v); + value next; + + CAMLassert (Color_val (v) == Caml_blue); + if (wosz <= BF_NUM_SMALL){ + while (1){ + next = *bf_small_fl[wosz].merge; + if (next == Val_NULL){ + set_map (wosz); + break; + } + if (Bp_val (next) >= Bp_val (v)) break; + bf_small_fl[wosz].merge = &Next_small (next); + } + Next_small (v) = *bf_small_fl[wosz].merge; + *bf_small_fl[wosz].merge = v; + bf_small_fl[wosz].merge = &Next_small (v); + }else{ + bf_insert_block ((large_free_block *) v); + } +} + +/* Remove a given block from the free set. */ +static void bf_remove (value v) +{ + mlsize_t wosz = Wosize_val (v); + + CAMLassert (Color_val (v) == Caml_blue); + if (wosz <= BF_NUM_SMALL){ + while (*bf_small_fl[wosz].merge != v){ + CAMLassert (Bp_val (*bf_small_fl[wosz].merge) < Bp_val (v)); + bf_small_fl[wosz].merge = &Next_small (*bf_small_fl[wosz].merge); + } + *bf_small_fl[wosz].merge = Next_small (v); + if (bf_small_fl[wosz].free == Val_NULL) unset_map (wosz); + }else{ + large_free_block *b = (large_free_block *) v; + CAMLassert (bf_is_in_tree (b)); + CAMLassert (b->prev->next == b); + CAMLassert (b->next->prev == b); + if (b->isnode){ + large_free_block **p = bf_search (bf_large_wosize (b)); + CAMLassert (*p != NULL); + if (b->next == b){ + bf_remove_node (p); + }else{ + large_free_block *n = b->next; + n->prev = b->prev; + b->prev->next = n; + *p = n; + n->isnode = 1; + n->left = b->left; + n->right = b->right; +#ifdef DEBUG + Field ((value) b, 0) = Debug_free_major; + b->left = b->right = b->next = b->prev = + (large_free_block *) Debug_free_major; +#endif + } + }else{ + b->prev->next = b->next; + b->next->prev = b->prev; + } + } +} + +/* Split the given block, return a new block of the given size. + The remnant is still at the same address, its size is changed + and its color becomes white. + The size of the free set is decremented by the whole block size + and the caller must readjust it if the remnant is reinserted or + remains in the free set. + The size of [v] must be strictly greater than [wosz]. +*/ +static header_t *bf_split_small (mlsize_t wosz, value v) +{ + intnat blocksz = Whsize_val (v); + intnat remwhsz = blocksz - Whsize_wosize (wosz); + + CAMLassert (Wosize_val (v) > wosz); + caml_fl_cur_wsz -= blocksz; + Hd_val (v) = Make_header (Wosize_whsize (remwhsz), Abstract_tag, Caml_white); + return (header_t *) &Field (v, Wosize_whsize (remwhsz)); +} + +/* Split the given block, return a new block of the given size. + The original block is at the same address but its size is changed. + Its color and tag are changed as appropriate for calling the + insert_remnant* functions. + The size of the free set is decremented by the whole block size + and the caller must readjust it if the remnant is reinserted or + remains in the free set. + The size of [v] must be strictly greater than [wosz]. +*/ +static header_t *bf_split (mlsize_t wosz, value v) +{ + header_t hd = Hd_val (v); + mlsize_t remwhsz = Whsize_hd (hd) - Whsize_wosize (wosz); + + CAMLassert (Wosize_val (v) > wosz); + CAMLassert (remwhsz > 0); + caml_fl_cur_wsz -= Whsize_hd (hd); + if (remwhsz <= Whsize_wosize (BF_NUM_SMALL)){ + /* Same as bf_split_small. */ + Hd_val (v) = Make_header (Wosize_whsize(remwhsz), Abstract_tag, Caml_white); + }else{ + Hd_val (v) = Make_header (Wosize_whsize (remwhsz), 0, Caml_blue); + } + return (header_t *) &Field (v, Wosize_whsize (remwhsz)); +} + +/* Allocate from a large block at [p]. If the node is single and the remaining + size is greater than [bound], it stays at the same place in the tree. + If [set_least] is true, [wosz] is guaranteed to be [<= BF_NUM_SMALL], so + the block has the smallest size in the tree. + In this case, the large block becomes (or remains) the single smallest + in the tree and we set the [bf_large_least] pointer. +*/ +static header_t *bf_alloc_from_large (mlsize_t wosz, large_free_block **p, + mlsize_t bound, int set_least) +{ + large_free_block *n = *p; + large_free_block *b; + header_t *result; + mlsize_t wosize_n = bf_large_wosize (n); + + CAMLassert (bf_large_wosize (n) >= wosz); + if (n->next == n){ + if (wosize_n > bound + Whsize_wosize (wosz)){ + /* TODO splay at [n]? if the remnant is larger than [wosz]? */ + if (set_least){ + CAMLassert (bound == BF_NUM_SMALL); + bf_large_least = n; + } + result = bf_split (wosz, (value) n); + caml_fl_cur_wsz += Whsize_wosize (wosize_n) - Whsize_wosize (wosz); + /* remnant stays in tree */ + return result; + }else{ + bf_remove_node (p); + if (wosize_n == wosz){ + caml_fl_cur_wsz -= Whsize_wosize (wosz); + return Hp_val ((value) n); + }else{ + result = bf_split (wosz, (value) n); + bf_insert_remnant ((value) n); + return result; + } + } + }else{ + b = n->next; + CAMLassert (bf_large_wosize (b) == bf_large_wosize (n)); + n->next = b->next; + b->next->prev = n; + if (wosize_n == wosz){ + caml_fl_cur_wsz -= Whsize_wosize (wosz); + return Hp_val ((value) b); + }else{ + result = bf_split (wosz, (value) b); + bf_insert_remnant ((value) b); + /* TODO: splay at [n] if the remnant is smaller than [wosz] */ + if (set_least){ + CAMLassert (bound == BF_NUM_SMALL); + if (bf_large_wosize (b) > BF_NUM_SMALL){ + bf_large_least = b; + } + } + return result; + } + } +} + +static header_t *bf_allocate_from_tree (mlsize_t wosz, int set_least) +{ + large_free_block **n; + mlsize_t bound; + + n = bf_search_best (wosz, &bound); + if (n == NULL) return NULL; + return bf_alloc_from_large (wosz, n, bound, set_least); +} + +static header_t *bf_allocate (mlsize_t wosz) +{ + value block; + header_t *result; + + CAMLassert (sizeof (char *) == sizeof (value)); + CAMLassert (wosz >= 1); + +#ifdef CAML_INSTR + if (wosz < 10){ + ++instr_size[wosz]; + }else if (wosz < 100){ + ++instr_size[wosz/10 + 9]; + }else{ + ++instr_size[19]; + } +#endif /* CAML_INSTR */ + + if (wosz <= BF_NUM_SMALL){ + if (bf_small_fl[wosz].free != Val_NULL){ + /* fast path: allocate from the corresponding free list */ + block = bf_small_fl[wosz].free; + if (bf_small_fl[wosz].merge == &Next_small (block)){ + bf_small_fl[wosz].merge = &bf_small_fl[wosz].free; + } + bf_small_fl[wosz].free = Next_small (block); + if (bf_small_fl[wosz].free == Val_NULL) unset_map (wosz); + caml_fl_cur_wsz -= Whsize_wosize (wosz); + FREELIST_DEBUG_bf_check (); + return Hp_val (block); + }else{ + /* allocate from the next available size */ + mlsize_t s = ffs (bf_small_map & ((-1) << wosz)); + FREELIST_DEBUG_bf_check (); + if (s != 0){ + block = bf_small_fl[s].free; + CAMLassert (block != Val_NULL); + if (bf_small_fl[s].merge == &Next_small (block)){ + bf_small_fl[s].merge = &bf_small_fl[s].free; + } + bf_small_fl[s].free = Next_small (block); + if (bf_small_fl[s].free == Val_NULL) unset_map (s); + result = bf_split_small (wosz, block); + bf_insert_remnant_small (block); + FREELIST_DEBUG_bf_check (); + return result; + } + } + /* Failed to find a suitable small block: try [bf_large_least]. */ + if (bf_large_least != NULL){ + mlsize_t least_wosz = bf_large_wosize (bf_large_least); + if (least_wosz > BF_NUM_SMALL + Whsize_wosize (wosz)){ + result = bf_split (wosz, (value) bf_large_least); + caml_fl_cur_wsz += Whsize_wosize (least_wosz) - Whsize_wosize (wosz); + /* remnant stays in tree */ + CAMLassert (Color_val ((value) bf_large_least) == Caml_blue); + return result; + } + } + + /* Allocate from the tree and update [bf_large_least]. */ + result = bf_allocate_from_tree (wosz, 1); + FREELIST_DEBUG_bf_check (); + return result; + }else{ + result = bf_allocate_from_tree (wosz, 0); + FREELIST_DEBUG_bf_check (); + return result; + } +} + +static void bf_init_merge (void) +{ + mlsize_t i; + +#ifdef CAML_INSTR + for (i = 1; i < 20; i++){ + CAML_INSTR_INT (instr_name[i], instr_size[i]); + instr_size[i] = 0; + } +#endif /* CAML_INSTR */ + + caml_fl_merge = Val_NULL; + + for (i = 1; i <= BF_NUM_SMALL; i++){ + /* At the beginning of each small free list is a segment of remnants + that were pushed back to the list after splitting. These are white + and they are not in order. We need to remove them + from the list for coalescing to work. They + will be picked up by the sweeping code and inserted in the right + place in the list. + */ + value p = bf_small_fl[i].free; + while (1){ + if (p == Val_NULL){ + unset_map (i); + break; + } + if (Color_val (p) == Caml_blue) break; + CAMLassert (Color_val (p) == Caml_white); + caml_fl_cur_wsz -= Whsize_val (p); + p = Next_small (p); + } + bf_small_fl[i].free = p; + /* Set the merge pointer to its initial value */ + bf_small_fl[i].merge = &bf_small_fl[i].free; + } +} + +static void bf_reset (void) +{ + mlsize_t i; + + for (i = 1; i <= BF_NUM_SMALL; i++){ + bf_small_fl[i].free = Val_NULL; + bf_small_fl[i].merge = &bf_small_fl[i].free; + } + bf_small_map = 0; + bf_large_tree = NULL; + bf_large_least = NULL; + caml_fl_cur_wsz = 0; + bf_init_merge (); +} + +static header_t *bf_merge_block (value bp, char *limit) +{ + value start; + value cur; + mlsize_t wosz; + + CAMLassert (Color_val (bp) == Caml_white); + /* Find the starting point of the current run of free blocks. */ + if (caml_fl_merge != Val_NULL && Next_in_mem (caml_fl_merge) == bp + && Color_val (caml_fl_merge) == Caml_blue){ + start = caml_fl_merge; + bf_remove (start); + }else{ + start = bp; + } + cur = bp; + while (1){ + /* This slightly convoluted loop is just going over the run of + white or blue blocks, doing the right thing for each color, and + stopping on a gray or black block or when limit is passed. + It is convoluted because we start knowing that the first block + is white. */ + white: + if (Tag_val (cur) == Custom_tag){ + void (*final_fun)(value) = Custom_ops_val(cur)->finalize; + if (final_fun != NULL) final_fun(cur); + } + caml_fl_cur_wsz += Whsize_val (cur); + next: + cur = Next_in_mem (cur); + if (Hp_val (cur) >= (header_t *) limit){ + CAMLassert (Hp_val (cur) == (header_t *) limit); + goto end_of_run; + } + switch (Color_val (cur)){ + case Caml_white: goto white; + case Caml_blue: bf_remove (cur); goto next; + case Caml_gray: + case Caml_black: + goto end_of_run; + } + } + end_of_run: + wosz = Wosize_whsize ((value *) cur - (value *) start); +#ifdef DEBUG + { + value *p; + for (p = (value *) start; p < (value *) Hp_val (cur); p++){ + *p = Debug_free_major; + } + } +#endif + while (wosz > Max_wosize){ + Hd_val (start) = Make_header (Max_wosize, 0, Caml_blue); + bf_insert_sweep (start); + start = Next_small (start); + wosz -= Whsize_wosize (Max_wosize); + } + if (wosz > 0){ + Hd_val (start) = Make_header (wosz, 0, Caml_blue); + bf_insert_sweep (start); + }else{ + Hd_val (start) = Make_header (0, 0, Caml_white); + caml_fl_cur_wsz -= Whsize_wosize (0); + } + FREELIST_DEBUG_bf_check (); + return Hp_val (cur); +} + +static void bf_add_blocks (value bp) +{ + while (bp != Val_NULL){ + value next = Next_small (bp); + mlsize_t wosz = Wosize_val (bp); + + if (wosz > BF_NUM_SMALL){ + caml_fl_cur_wsz += Whsize_wosize (wosz); + bf_insert_block ((large_free_block *) bp); + }else{ + Hd_val (bp) = Make_header (wosz, Abstract_tag, Caml_white); + bf_insert_remnant_small (bp); + } + bp = next; + } +} + +static void bf_make_free_blocks (value *p, mlsize_t size, int do_merge, + int color) +{ + mlsize_t sz, wosz; + + while (size > 0){ + if (size > Whsize_wosize (Max_wosize)){ + sz = Whsize_wosize (Max_wosize); + }else{ + sz = size; + } + wosz = Wosize_whsize (sz); + if (do_merge){ + if (wosz <= BF_NUM_SMALL){ + color = Caml_white; + }else{ + color = Caml_blue; + } + *(header_t *)p = Make_header (wosz, 0, color); + bf_insert_remnant (Val_hp (p)); + }else{ + *(header_t *)p = Make_header (wosz, 0, color); + } size -= sz; p += sz; } } -void caml_set_allocation_policy (uintnat p) +/*********************** policy selection *****************************/ + +enum { + policy_next_fit = 0, + policy_first_fit = 1, + policy_best_fit = 2, +}; + +uintnat caml_allocation_policy = policy_next_fit; + +/********************* exported functions *****************************/ + +/* [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, or NULL if no suitable block + is found in the free set. +*/ +header_t *(*caml_fl_p_allocate) (mlsize_t wo_sz) = &nf_allocate; + +/* Initialize the merge_block machinery (at start of sweeping). */ +void (*caml_fl_p_init_merge) (void) = &nf_init_merge; + +/* This is called by caml_compact_heap. */ +void (*caml_fl_p_reset) (void) = &nf_reset; + +/* [caml_fl_merge_block] returns the head pointer of the next block after [bp], + because merging blocks may change the size of [bp]. */ +header_t *(*caml_fl_p_merge_block) (value bp, char *limit) = &nf_merge_block; + +/* [bp] must point to a list of blocks of wosize >= 1 chained by their field 0, + terminated by Val_NULL, and field 1 of the first block must point to + the last block. + The blocks must be blue. +*/ +void (*caml_fl_p_add_blocks) (value bp) = &nf_add_blocks; + +/* Cut a block of memory into pieces of size [Max_wosize], give them headers, + and optionally merge them into the free list. + arguments: + p: pointer to the first word of the block + size: size of the block (in words) + do_merge: 1 -> do merge; 0 -> do not merge + color: which color to give to the pieces; if [do_merge] is 1, this + is overridden by the merge code, but we have historically used + [Caml_white]. +*/ +void (*caml_fl_p_make_free_blocks) + (value *p, mlsize_t size, int do_merge, int color) + = &nf_make_free_blocks; +#ifdef DEBUG +void (*caml_fl_p_check) (void) = &nf_check; +#endif + +void caml_set_allocation_policy (intnat p) { switch (p){ - case Policy_next_fit: - fl_prev = Fl_head; - policy = p; + case policy_next_fit: default: + caml_allocation_policy = policy_next_fit; + caml_fl_p_allocate = &nf_allocate; + caml_fl_p_init_merge = &nf_init_merge; + caml_fl_p_reset = &nf_reset; + caml_fl_p_merge_block = &nf_merge_block; + caml_fl_p_add_blocks = &nf_add_blocks; + caml_fl_p_make_free_blocks = &nf_make_free_blocks; +#ifdef DEBUG + caml_fl_p_check = &nf_check; +#endif break; - case Policy_first_fit: - flp_size = 0; - beyond = Val_NULL; - policy = p; + case policy_first_fit: + caml_allocation_policy = policy_first_fit; + caml_fl_p_allocate = &ff_allocate; + caml_fl_p_init_merge = &ff_init_merge; + caml_fl_p_reset = &ff_reset; + caml_fl_p_merge_block = &ff_merge_block; + caml_fl_p_add_blocks = &ff_add_blocks; + caml_fl_p_make_free_blocks = &ff_make_free_blocks; +#ifdef DEBUG + caml_fl_p_check = &ff_check; +#endif break; - default: + case policy_best_fit: + caml_allocation_policy = policy_best_fit; + caml_fl_p_allocate = &bf_allocate; + caml_fl_p_init_merge = &bf_init_merge; + caml_fl_p_reset = &bf_reset; + caml_fl_p_merge_block = &bf_merge_block; + caml_fl_p_add_blocks = &bf_add_blocks; + caml_fl_p_make_free_blocks = &bf_make_free_blocks; +#ifdef DEBUG + caml_fl_p_check = &bf_check; +#endif break; } } |