best-fit allocator (#8809)

9 files changed, 1588 insertions, 271 deletions

diff --git a/runtime/caml/compact.h b/runtime/caml/compact.h
index e29d0e86f9..5f189507d5 100644
--- a/runtime/caml/compact.h
+++ b/runtime/caml/compact.h
@@ -22,7 +22,12 @@
 #include "misc.h"
 #include "mlvalues.h"
 
-void caml_compact_heap (void);
+/* [caml_compact_heap] compacts the heap and optionally changes the
+   allocation policy.
+   if [new_allocation_policy] is -1, the policy is not changed.
+*/
+void caml_compact_heap (intnat new_allocation_policy);
+
 void caml_compact_heap_maybe (void);
 void caml_invert_root (value v, value *p);
 
diff --git a/runtime/caml/freelist.h b/runtime/caml/freelist.h
index 54e0e822f4..657e6883b7 100644
--- a/runtime/caml/freelist.h
+++ b/runtime/caml/freelist.h
@@ -25,13 +25,43 @@
 
 extern asize_t caml_fl_cur_wsz;
 
-header_t *caml_fl_allocate (mlsize_t wo_sz);
-void caml_fl_init_merge (void);
-void caml_fl_reset (void);
-header_t *caml_fl_merge_block (value);
-void caml_fl_add_blocks (value);
-void caml_make_free_blocks (value *, mlsize_t wsz, int, int);
-void caml_set_allocation_policy (uintnat);
+/* See [freelist.c] for usage info on these functions. */
+extern header_t *(*caml_fl_p_allocate) (mlsize_t wo_sz);
+extern void (*caml_fl_p_init_merge) (void);
+extern void (*caml_fl_p_reset) (void);
+extern header_t *(*caml_fl_p_merge_block) (value bp, char *limit);
+extern void (*caml_fl_p_add_blocks) (value bp);
+extern void (*caml_fl_p_make_free_blocks)
+  (value *p, mlsize_t size, int do_merge, int color);
+#ifdef DEBUG
+extern void (*caml_fl_p_check) (void);
+#endif
+
+static inline header_t *caml_fl_allocate (mlsize_t wo_sz)
+  { return (*caml_fl_p_allocate) (wo_sz); }
+
+static inline void caml_fl_init_merge (void)
+  { (*caml_fl_p_init_merge) (); }
+
+static inline void caml_fl_reset (void)
+  { (*caml_fl_p_reset) (); }
+
+static inline header_t *caml_fl_merge_block (value bp, char *limit)
+  { return (*caml_fl_p_merge_block) (bp, limit); }
+
+static inline void caml_fl_add_blocks (value bp)
+  { (*caml_fl_p_add_blocks) (bp); }
+
+static inline void caml_make_free_blocks
+  (value *p, mlsize_t size, int do_merge, int color)
+  { (*caml_fl_p_make_free_blocks) (p, size, do_merge, color); }
+
+extern void caml_set_allocation_policy (intnat);
+
+#ifdef DEBUG
+static inline void caml_fl_check (void)
+  { (*caml_fl_p_check) (); }
+#endif
 
 #endif /* CAML_INTERNALS */
 
diff --git a/runtime/caml/misc.h b/runtime/caml/misc.h
index 4087142b4a..fcbdf0d27f 100644
--- a/runtime/caml/misc.h
+++ b/runtime/caml/misc.h
@@ -369,6 +369,7 @@ int caml_runtime_warnings_active(void);
   01 -> fields of free list blocks in major heap
   03 -> heap chunks deallocated by heap shrinking
   04 -> fields deallocated by [caml_obj_truncate]
+  05 -> unused child pointers in large free blocks
   10 -> uninitialised fields of minor objects
   11 -> uninitialised fields of major objects
   15 -> uninitialised words of [caml_stat_alloc_aligned] blocks
@@ -382,6 +383,7 @@ int caml_runtime_warnings_active(void);
 #define Debug_free_major     Debug_tag (0x01)
 #define Debug_free_shrink    Debug_tag (0x03)
 #define Debug_free_truncate  Debug_tag (0x04)
+#define Debug_free_unused    Debug_tag (0x05)
 #define Debug_uninit_minor   Debug_tag (0x10)
 #define Debug_uninit_major   Debug_tag (0x11)
 #define Debug_uninit_align   Debug_tag (0x15)
diff --git a/runtime/caml/s.h.in b/runtime/caml/s.h.in
index 2e7db51604..b618309d62 100644
--- a/runtime/caml/s.h.in
+++ b/runtime/caml/s.h.in
@@ -243,6 +243,9 @@
 
 #undef HAS_EXECVPE
 
+#undef HAS_FFS
+#undef HAS_BITSCANFORWARD
+
 #undef HAS_STACK_OVERFLOW_DETECTION
 
 #undef HAS_SIGWAIT
diff --git a/runtime/compact.c b/runtime/compact.c
index eb64db42f5..75c973fab9 100644
--- a/runtime/compact.c
+++ b/runtime/compact.c
@@ -158,7 +158,7 @@ static char *compact_allocate (mlsize_t size)
   return adr;
 }
 
-static void do_compaction (void)
+static void do_compaction (intnat new_allocation_policy)
 {
   char *ch, *chend;
   CAMLassert (caml_gc_phase == Phase_idle);
@@ -405,9 +405,14 @@ static void do_compaction (void)
     }
   }
 
-  /* Rebuild the free list. */
+  /* Rebuild the free list. This is the right time for a change of
+     allocation policy, since we are rebuilding the allocator's data
+     structures from scratch. */
   {
     ch = caml_heap_start;
+    if (new_allocation_policy != -1){
+      caml_set_allocation_policy (new_allocation_policy);
+    }
     caml_fl_reset ();
     while (ch != NULL){
       if (Chunk_size (ch) > Chunk_alloc (ch)){
@@ -424,7 +429,7 @@ static void do_compaction (void)
 
 uintnat caml_percent_max;  /* used in gc_ctrl.c and memory.c */
 
-void caml_compact_heap (void)
+void caml_compact_heap (intnat new_allocation_policy)
 {
   uintnat target_wsz, live;
   CAML_INSTR_SETUP(tmr, "compact");
@@ -437,7 +442,7 @@ void caml_compact_heap (void)
   CAMLassert (Caml_state->custom_table->ptr ==
               Caml_state->custom_table->base);
 
-  do_compaction ();
+  do_compaction (new_allocation_policy);
   CAML_INSTR_TIME (tmr, "compact/main");
   /* Compaction may fail to shrink the heap to a reasonable size
      because it deals in complete chunks: if a very large chunk
@@ -500,7 +505,7 @@ void caml_compact_heap (void)
     if (Caml_state->stat_heap_wsz > Caml_state->stat_top_heap_wsz){
       Caml_state->stat_top_heap_wsz = Caml_state->stat_heap_wsz;
     }
-    do_compaction ();
+    do_compaction (-1);
     CAMLassert (Caml_state->stat_heap_chunks == 1);
     CAMLassert (Chunk_next (caml_heap_start) == NULL);
     CAMLassert (Caml_state->stat_heap_wsz == Wsize_bsize (Chunk_size (chunk)));
@@ -559,7 +564,7 @@ void caml_compact_heap_maybe (void)
                             ARCH_INTNAT_PRINTF_FORMAT "u%%\n",
                      (uintnat) fp);
     if (fp >= caml_percent_max)
-         caml_compact_heap ();
+         caml_compact_heap (-1);
     else
          caml_gc_message (0x200, "Automatic compaction aborted.\n");
 
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;
   }
 }
diff --git a/runtime/gc_ctrl.c b/runtime/gc_ctrl.c
index fb5019a85a..e4bb3f1a1f 100644
--- a/runtime/gc_ctrl.c
+++ b/runtime/gc_ctrl.c
@@ -212,6 +212,7 @@ static value heap_stats (int returnstats)
 
 #ifdef DEBUG
   caml_final_invariant_check();
+  caml_fl_check ();
 #endif
 
   CAMLassert (heap_chunks == Caml_state->stat_heap_chunks);
@@ -414,7 +415,7 @@ CAMLprim value caml_gc_set(value v)
   uintnat newpf, newpm;
   asize_t newheapincr;
   asize_t newminwsz;
-  uintnat oldpolicy;
+  uintnat newpolicy;
   uintnat new_custom_maj, new_custom_min, new_custom_sz;
   CAML_INSTR_SETUP (tmr, "");
 
@@ -451,12 +452,6 @@ CAMLprim value caml_gc_set(value v)
                        caml_major_heap_increment);
     }
   }
-  oldpolicy = caml_allocation_policy;
-  caml_set_allocation_policy (Long_val (Field (v, 6)));
-  if (oldpolicy != caml_allocation_policy){
-    caml_gc_message (0x20, "New allocation policy: %"
-                     ARCH_INTNAT_PRINTF_FORMAT "u\n", caml_allocation_policy);
-  }
 
   /* This field was added in 4.03.0. */
   if (Wosize_val (v) >= 8){
@@ -493,15 +488,32 @@ CAMLprim value caml_gc_set(value v)
     }
   }
 
-    /* Minor heap size comes last because it will trigger a minor collection
-       (thus invalidating [v]) and it can raise [Out_of_memory]. */
+  /* Save field 0 before [v] is invalidated. */
   newminwsz = norm_minsize (Long_val (Field (v, 0)));
+
+  /* Switching allocation policies must trigger a compaction, so it
+     invalidates [v]. */
+  newpolicy = Long_val (Field (v, 6));
+  if (newpolicy != caml_allocation_policy){
+    caml_empty_minor_heap ();
+    caml_finish_major_cycle ();
+    caml_finish_major_cycle ();
+    caml_compact_heap (newpolicy);
+    caml_gc_message (0x20, "New allocation policy: %"
+                     ARCH_INTNAT_PRINTF_FORMAT "u\n", newpolicy);
+  }
+
+  /* Minor heap size comes last because it can raise [Out_of_memory]. */
   if (newminwsz != Caml_state->minor_heap_wsz){
     caml_gc_message (0x20, "New minor heap size: %"
                      ARCH_SIZET_PRINTF_FORMAT "uk words\n", newminwsz / 1024);
     caml_set_minor_heap_size (Bsize_wsize (newminwsz));
   }
   CAML_INSTR_TIME (tmr, "explicit/gc_set");
+
+  /* The compaction may have triggered some finalizers that we need to call. */
+  caml_check_urgent_gc (Val_unit);
+
   return Val_unit;
 }
 
@@ -527,7 +539,7 @@ static void test_and_compact (void)
                    (uintnat) fp);
   if (fp >= caml_percent_max){
     caml_gc_message (0x200, "Automatic compaction triggered.\n");
-    caml_compact_heap ();
+    caml_compact_heap (-1);
   }
 }
 
@@ -579,7 +591,7 @@ CAMLprim value caml_gc_compaction(value v)
   caml_check_urgent_gc (Val_unit);
   caml_empty_minor_heap ();
   caml_finish_major_cycle ();
-  caml_compact_heap ();
+  caml_compact_heap (-1);
   caml_check_urgent_gc (Val_unit);
   CAML_INSTR_TIME (tmr, "explicit/gc_compact");
   return Val_unit;
diff --git a/runtime/major_gc.c b/runtime/major_gc.c
index 3c7976a945..7a4142d976 100644
--- a/runtime/major_gc.c
+++ b/runtime/major_gc.c
@@ -562,11 +562,7 @@ static void sweep_slice (intnat work)
       caml_gc_sweep_hp += Bhsize_hd (hd);
       switch (Color_hd (hd)){
       case Caml_white:
-        if (Tag_hd (hd) == Custom_tag){
-          void (*final_fun)(value) = Custom_ops_val(Val_hp(hp))->finalize;
-          if (final_fun != NULL) final_fun(Val_hp(hp));
-        }
-        caml_gc_sweep_hp = (char *) caml_fl_merge_block (Val_hp (hp));
+        caml_gc_sweep_hp = (char *) caml_fl_merge_block (Val_hp (hp), limit);
         break;
       case Caml_blue:
         /* Only the blocks of the free-list are blue.  See [freelist.c]. */
diff --git a/runtime/startup_aux.c b/runtime/startup_aux.c
index a187d91a86..e9ed93dc11 100644
--- a/runtime/startup_aux.c
+++ b/runtime/startup_aux.c
@@ -91,9 +91,10 @@ void caml_parse_ocamlrunparam(void)
   if (opt != NULL){
     while (*opt != '\0'){
       switch (*opt++){
-      case 'a': scanmult (opt, &p); caml_set_allocation_policy (p); break;
+      case 'a': scanmult (opt, &p); caml_set_allocation_policy ((intnat) p);
+        break;
       case 'b': scanmult (opt, &p); caml_record_backtrace(Val_bool (p));
-                    break;
+        break;
       case 'c': scanmult (opt, &p); caml_cleanup_on_exit = (p != 0); break;
       case 'h': scanmult (opt, &caml_init_heap_wsz); break;
       case 'H': scanmult (opt, &caml_use_huge_pages); break;