ocaml/byterun/freelist.c

/***********************************************************************/
/*                                                                     */
/*                           Objective Caml                            */
/*                                                                     */
/*             Damien Doligez, projet Para, INRIA Rocquencourt         */
/*                                                                     */
/*  Copyright 1996 Institut National de Recherche en Informatique et   */
/*  en Automatique.  All rights reserved.  This file is distributed    */
/*  under the terms of the GNU Library General Public License, with    */
/*  the special exception on linking described in file ../LICENSE.     */
/*                                                                     */
/***********************************************************************/

/* $Id$ */

#include "config.h"
#include "freelist.h"
#include "gc.h"
#include "gc_ctrl.h"
#include "major_gc.h"
#include "misc.h"
#include "mlvalues.h"

/* The free-list is kept sorted by increasing addresses.
   This makes the merging of adjacent free blocks possible.
   (See [caml_fl_merge_block].)
*/

typedef struct {
  char *next_bp;   /* Pointer to the first byte of the next block. */
} block;

/* 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_bp;
  value filler2; /* Make sure the sentinel is never adjacent to any block. */
} sentinel = {0, Make_header (0, 0, Caml_blue), 0, 0};

#define Fl_head ((char *) (&(sentinel.first_bp)))
static char *fl_prev = Fl_head;  /* Current allocation pointer. */
static char *fl_last = NULL;     /* Last block in the list.  Only valid
                                 just after [caml_fl_allocate] returns NULL. */
char *caml_fl_merge = Fl_head;   /* Current insertion pointer.  Managed
                                    jointly with [sweep_slice]. */
asize_t caml_fl_cur_size = 0;    /* Number of words in the free list,
                                    including headers but not fragments. */

#define Next(b) (((block *) (b))->next_bp)

#ifdef DEBUG
static void fl_check (void)
{
  char *cur, *prev;
  int prev_found = 0, merge_found = 0;
  uintnat size_found = 0;

  prev = Fl_head;
  cur = Next (prev);
  while (cur != NULL){
    size_found += Whsize_bp (cur);
    Assert (Is_in_heap (cur));
    if (cur == fl_prev) prev_found = 1;
    if (cur == caml_fl_merge) merge_found = 1;
    prev = cur;
    cur = Next (prev);
  }
  Assert (prev_found || fl_prev == Fl_head);
  Assert (merge_found || caml_fl_merge == Fl_head);
  Assert (size_found == caml_fl_cur_size);
}
#endif

/* [allocate_block] is called by [caml_fl_allocate].  Given a suitable free
   block and the desired size, it allocates a new block from the free
   block.  There are three cases:
   0. The free block has the desired size.  Detach the block from the
      free-list and return it.
   1. The free block is 1 word longer than the desired size.  Detach
      the block from the free list.  The remaining word cannot be linked:
      turn it into an empty block (header only), and return the rest.
   2. The free block is big enough.  Split it in two and return the right
      block.
   In all cases, the allocated block is right-justified in the free block:
   it is located in the high-address words of the free block.  This way,
   the linking of the free-list does not change in case 2.
*/
static char *allocate_block (mlsize_t wh_sz, char *prev, char *cur)
{
  header_t h = Hd_bp (cur);
                                             Assert (Whsize_hd (h) >= wh_sz);
  if (Wosize_hd (h) < wh_sz + 1){                        /* Cases 0 and 1. */
    caml_fl_cur_size -= Whsize_hd (h);
    Next (prev) = Next (cur);
                    Assert (Is_in_heap (Next (prev)) || Next (prev) == NULL);
    if (caml_fl_merge == cur) caml_fl_merge = prev;
#ifdef DEBUG
    fl_last = NULL;
#endif
      /* In case 1, the following creates the empty block correctly.
         In case 0, it gives an invalid header to the block.  The function
         calling [caml_fl_allocate] will overwrite it. */
    Hd_op (cur) = Make_header (0, 0, Caml_white);
  }else{                                                        /* Case 2. */
    caml_fl_cur_size -= wh_sz;
    Hd_op (cur) = Make_header (Wosize_hd (h) - wh_sz, 0, Caml_blue);
  }
  fl_prev = prev;
  return cur + Bosize_hd (h) - Bsize_wsize (wh_sz);
}  

/* [caml_fl_allocate] does not set the header of the newly allocated block.
   The calling function must do it before any GC function gets called.
   [caml_fl_allocate] returns a head pointer.
*/
char *caml_fl_allocate (mlsize_t wo_sz)
{
  char *cur, *prev;
                                  Assert (sizeof (char *) == sizeof (value));
                                  Assert (fl_prev != NULL);
                                  Assert (wo_sz >= 1);
    /* Search from [fl_prev] to the end of the list. */
  prev = fl_prev;
  cur = Next (prev);
  while (cur != NULL){                             Assert (Is_in_heap (cur));
    if (Wosize_bp (cur) >= wo_sz){
      return allocate_block (Whsize_wosize (wo_sz), prev, cur);
    }
    prev = cur;
    cur = Next (prev);
  }
  fl_last = prev;
    /* Search from the start of the list to [fl_prev]. */
  prev = Fl_head;
  cur = Next (prev);
  while (prev != fl_prev){
    if (Wosize_bp (cur) >= wo_sz){
      return allocate_block (Whsize_wosize (wo_sz), prev, cur);
    }
    prev = cur;
    cur = Next (prev);
  }
    /* No suitable block was found. */
  return NULL;
}

static char *last_fragment;

void caml_fl_init_merge (void)
{
  last_fragment = NULL;
  caml_fl_merge = Fl_head;
#ifdef DEBUG
  fl_check ();
#endif
}

/* This is called by caml_compact_heap. */
void caml_fl_reset (void)
{
  Next (Fl_head) = 0;
  fl_prev = Fl_head;
  caml_fl_cur_size = 0;
  caml_fl_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]. */
char *caml_fl_merge_block (char *bp)
{
  char *prev, *cur, *adj;
  header_t hd = Hd_bp (bp);
  mlsize_t prev_wosz;

  caml_fl_cur_size += Whsize_hd (hd);
  
#ifdef DEBUG
  {
    mlsize_t i;
    for (i = 0; i < Wosize_hd (hd); i++){
      Field (Val_bp (bp), i) = Debug_free_major;
    }
  }
#endif
  prev = caml_fl_merge;
  cur = Next (prev);
  /* The sweep code makes sure that this is the right place to insert
     this block: */
  Assert (prev < bp || prev == Fl_head);
  Assert (cur > bp || cur == NULL);

  /* If [last_fragment] and [bp] are adjacent, merge them. */
  if (last_fragment == Hp_bp (bp)){
    mlsize_t bp_whsz = Whsize_bp (bp);
    if (bp_whsz <= Max_wosize){
      hd = Make_header (bp_whsz, 0, Caml_white);
      bp = last_fragment;
      Hd_bp (bp) = hd;
      caml_fl_cur_size += Whsize_wosize (0);
    }
  }

  /* If [bp] and [cur] are adjacent, remove [cur] from the free-list
     and merge them. */
  adj = bp + Bosize_hd (hd);
  if (adj == Hp_bp (cur)){
    char *next_cur = Next (cur);
    mlsize_t cur_whsz = Whsize_bp (cur);

    if (Wosize_hd (hd) + cur_whsz <= Max_wosize){
      Next (prev) = next_cur;
      if (fl_prev == cur) fl_prev = prev;
      hd = Make_header (Wosize_hd (hd) + cur_whsz, 0, Caml_blue);
      Hd_bp (bp) = hd;
      adj = bp + Bosize_hd (hd);
#ifdef DEBUG
      fl_last = NULL;
      Next (cur) = (char *) Debug_free_major;
      Hd_bp (cur) = Debug_free_major;
#endif
      cur = next_cur;
    }
  }
  /* If [prev] and [bp] are adjacent merge them, else insert [bp] into
     the free-list if it is big enough. */
  prev_wosz = Wosize_bp (prev);
  if (prev + Bsize_wsize (prev_wosz) == Hp_bp (bp)
      && prev_wosz + Whsize_hd (hd) < Max_wosize){
    Hd_bp (prev) = Make_header (prev_wosz + Whsize_hd (hd), 0,Caml_blue);
#ifdef DEBUG
    Hd_bp (bp) = Debug_free_major;
#endif
    Assert (caml_fl_merge == prev);
  }else if (Wosize_hd (hd) != 0){
    Hd_bp (bp) = Bluehd_hd (hd);
    Next (bp) = cur;
    Next (prev) = bp;
    caml_fl_merge = bp;
  }else{
    /* This is a fragment.  Leave it in white but remember it for eventual
       merging with the next block. */
    last_fragment = bp;
    caml_fl_cur_size -= Whsize_wosize (0);
  }
  return adj;
}

/* This is a heap extension.  We have to insert it in the right place
   in the free-list.
   [caml_fl_add_block] can only be called right after a call to
   [caml_fl_allocate] that returned NULL.
   Most of the heap extensions are expected to be at the end of the
   free list.  (This depends on the implementation of [malloc].)
*/
void caml_fl_add_block (char *bp)
{
                                                   Assert (fl_last != NULL);
                                            Assert (Next (fl_last) == NULL);
#ifdef DEBUG
  {
    mlsize_t i;
    for (i = 0; i < Wosize_bp (bp); i++){
      Field (Val_bp (bp), i) = Debug_free_major;
    }
  }
#endif

  caml_fl_cur_size += Whsize_bp (bp);

  if (bp > fl_last){
    Next (fl_last) = bp;
    Next (bp) = NULL;
  }else{
    char *cur, *prev;

    prev = Fl_head;
    cur = Next (prev);
    while (cur != NULL && cur < bp){   Assert (prev < bp || prev == Fl_head);
      prev = cur;
      cur = Next (prev);
    }                                  Assert (prev < bp || prev == Fl_head);
                                            Assert (cur > bp || cur == NULL);
    Next (bp) = cur;
    Next (prev) = bp;
    /* When inserting a block between [caml_fl_merge] and [caml_gc_sweep_hp],
       we must advance [caml_fl_merge] to the new block, so that [caml_fl_merge]
       is always the last free-list block before [caml_gc_sweep_hp]. */
    if (prev == caml_fl_merge && bp <= caml_gc_sweep_hp) caml_fl_merge = 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
*/
void caml_make_free_blocks (value *p, mlsize_t size, int do_merge)
{
  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, Caml_white);
    if (do_merge) caml_fl_merge_block (Bp_hp (p));
    size -= sz;
    p += sz;
  }
}