ocaml/runtime/weak.c

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

#define CAML_INTERNALS

/* Operations on weak arrays and ephemerons (named ephe here)*/

#include <string.h>

#include "caml/alloc.h"
#include "caml/fail.h"
#include "caml/major_gc.h"
#include "caml/memory.h"
#include "caml/mlvalues.h"
#include "caml/weak.h"
#include "caml/minor_gc.h"
#include "caml/signals.h"
#include "caml/eventlog.h"

value caml_ephe_list_head = 0;

static value ephe_dummy = 0;
value caml_ephe_none = (value) &ephe_dummy;

#define CAMLassert_valid_ephemeron(eph) do{                             \
    CAMLassert (Is_in_heap (eph));                                      \
    CAMLassert (Tag_val(eph) == Abstract_tag);                          \
    CAMLassert (CAML_EPHE_FIRST_KEY <= Wosize_val (eph));               \
}while(0)

#define CAMLassert_valid_offset(eph, offset) do{                        \
    CAMLassert_valid_ephemeron(eph);                                    \
    CAMLassert (0 <= offset);                                           \
    CAMLassert (offset < Wosize_val (eph) - CAML_EPHE_FIRST_KEY);       \
}while(0)

#ifdef DEBUG
#define CAMLassert_not_dead_value(v) do{                        \
    if (caml_gc_phase == Phase_clean                            \
        && Is_block(v)                                          \
        && Is_in_heap (v)) {                                    \
      if (Tag_val (v) == Infix_tag) v -= Infix_offset_val (v);  \
      CAMLassert ( !Is_white_val(v) );                          \
    }                                                           \
}while(0)
#else
#define CAMLassert_not_dead_value(v)
#endif

CAMLexport mlsize_t caml_ephemeron_num_keys(value eph)
{
  CAMLassert_valid_ephemeron(eph);
  return Wosize_val (eph) - CAML_EPHE_FIRST_KEY;
}

/** The minor heap is considered alive. */

/** Outside minor and major heap, x must be black. */
Caml_inline int Is_Dead_during_clean(value x)
{
  CAMLassert (x != caml_ephe_none);
  CAMLassert (caml_gc_phase == Phase_clean);
  if (!Is_block(x)) return 0;
  if (Tag_val(x) == Infix_tag) x -= Infix_offset_val(x);
#ifdef NO_NAKED_POINTERS
  return Is_white_val(x) && !Is_young (x);
#else
  return Is_white_val(x) && Is_in_heap (x);
#endif
}
/** The minor heap doesn't have to be marked, outside they should
    already be black
*/
Caml_inline int Must_be_Marked_during_mark(value x)
{
  CAMLassert (x != caml_ephe_none);
  CAMLassert (caml_gc_phase == Phase_mark);
#ifdef NO_NAKED_POINTERS
  return Is_block (x) && !Is_young (x);
#else
  return Is_block (x) && Is_in_heap (x);
#endif
}

/* [len] is a number of words (fields) */
CAMLexport value caml_ephemeron_create (mlsize_t len)
{
  mlsize_t size, i;
  value res;

  CAMLassert(len <= CAML_EPHE_MAX_WOSIZE);
  size = len + CAML_EPHE_FIRST_KEY;
  if (size < CAML_EPHE_FIRST_KEY || size > Max_wosize)
    caml_invalid_argument ("Weak.create");
  res = caml_alloc_shr (size, Abstract_tag);
  for (i = 1; i < size; i++) Field (res, i) = caml_ephe_none;
  Field (res, CAML_EPHE_LINK_OFFSET) = caml_ephe_list_head;
  caml_ephe_list_head = res;
  return res;
}

CAMLprim value caml_ephe_create (value len)
{
  value res = caml_ephemeron_create(Long_val(len));
  // run memprof callbacks
  return caml_process_pending_actions_with_root(res);
}

CAMLprim value caml_weak_create (value len)
{
  return caml_ephe_create(len);
}

/**
   Specificity of the cleaning phase (Phase_clean):

   The dead keys must be removed from the ephemerons and data removed
   when one the keys is dead. Here we call it cleaning the ephemerons.
   A specific phase of the GC is dedicated to this, Phase_clean. This
   phase is just after the mark phase, so the white values are dead
   values. It iterates the function caml_ephe_clean through all the
   ephemerons.

   However the GC is incremental and ocaml code can run on the middle
   of this cleaning phase. In order to respect the semantic of the
   ephemerons concerning dead values, the getter and setter must work
   as if the cleaning of all the ephemerons have been done at once.

   - key getter: Even if a dead key have not yet been replaced by
     caml_ephe_none, getting it should return none.
   - key setter: If we replace a dead key we need to set the data to
     caml_ephe_none and clean the ephemeron.

     This two cases are dealt by a call to do_check_key_clean that
     trigger the cleaning of the ephemerons when the accessed key is
     dead. This test is fast.

     In the case of value getter and value setter, there is no fast
     test because the removing of the data depend of the deadliness of the keys.
     We must always try to clean the ephemerons.

 */

#define None_val (Val_int(0))
#define Some_tag 0

/* If we are in Phase_clean we need to check if the key
   that is going to disappear is dead and so should trigger a cleaning
 */
static void do_check_key_clean(value ar, mlsize_t offset)
{
  CAMLassert (offset >= CAML_EPHE_FIRST_KEY);
  if (caml_gc_phase == Phase_clean){
    value elt = Field (ar, offset);
    if (elt != caml_ephe_none && Is_Dead_during_clean(elt)){
      Field(ar, offset) = caml_ephe_none;
      Field(ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
    };
  };
}

/* If we are in Phase_clean we need to do as if the key is empty when
   it will be cleaned during this phase */
Caml_inline int is_ephe_key_none(value ar, mlsize_t offset)
{
  value elt = Field (ar, offset);
  if (elt == caml_ephe_none){
    return 1;
  }else if (caml_gc_phase == Phase_clean && Is_Dead_during_clean(elt)){
    Field(ar, offset) = caml_ephe_none;
    Field(ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
    return 1;
  } else {
    return 0;
  }
}

static void do_set (value ar, mlsize_t offset, value v)
{
  if (Is_block (v) && Is_young (v)){
    /* modified version of caml_modify */
    value old = Field (ar, offset);
    Field (ar, offset) = v;
    if (!(Is_block (old) && Is_young (old))){
      add_to_ephe_ref_table (Caml_state->ephe_ref_table, ar, offset);
    }
  }else{
    Field (ar, offset) = v;
  }
}

CAMLexport void caml_ephemeron_set_key(value ar, mlsize_t offset, value k)
{
  CAMLassert_valid_offset(ar, offset);
  CAMLassert (Is_in_heap (ar));

  offset += CAML_EPHE_FIRST_KEY;
  do_check_key_clean(ar, offset);
  do_set (ar, offset, k);
}

CAMLprim value caml_ephe_set_key (value ar, value n, value el)
{
  caml_ephemeron_set_key(ar, Long_val(n), el);
  return Val_unit;
}

CAMLexport void caml_ephemeron_unset_key(value ar, mlsize_t offset)
{
  CAMLassert_valid_offset(ar, offset);
  CAMLassert (Is_in_heap (ar));

  offset += CAML_EPHE_FIRST_KEY;

  do_check_key_clean(ar, offset);
  Field (ar, offset) = caml_ephe_none;
}

CAMLprim value caml_ephe_unset_key (value ar, value n)
{
  caml_ephemeron_unset_key(ar, Long_val(n));
  return Val_unit;
}

/* deprecated (03/2016) */
value caml_ephe_set_key_option (value ar, value n, value el)
{
  if (Is_block (el)){
    CAMLassert (Wosize_val (el) == 1);
    caml_ephe_set_key(ar, n, Field (el, 0));
  }else{
    CAMLassert (el == None_val);
    caml_ephe_unset_key(ar, n);
  }
  return Val_unit;
}

/* deprecated (03/2016) */
CAMLprim value caml_weak_set (value ar, value n, value el)
{
  return caml_ephe_set_key_option(ar, n, el);
}

CAMLexport void caml_ephemeron_set_data (value ar, value el)
{
  CAMLassert_valid_ephemeron(ar);

  if (caml_gc_phase == Phase_clean){
    /* During this phase since we don't know which ephemerons have been
       cleaned we always need to check it. */
    caml_ephe_clean(ar);
  };
  do_set (ar, CAML_EPHE_DATA_OFFSET, el);
}

CAMLprim value caml_ephe_set_data (value ar, value el)
{
  caml_ephemeron_set_data (ar, el);
  return Val_unit;
}

CAMLexport void caml_ephemeron_unset_data (value ar)
{
  CAMLassert_valid_ephemeron(ar);

  Field (ar, CAML_EPHE_DATA_OFFSET) = caml_ephe_none;
}

CAMLprim value caml_ephe_unset_data (value ar)
{
  caml_ephemeron_unset_data (ar);
  return Val_unit;
}

static value optionalize(int status, value *x)
{
  CAMLparam0();
  CAMLlocal2(res, v);
  if(status) {
    v = *x;
    res = caml_alloc_small (1, Some_tag);
    Field (res, 0) = v;
  } else {
    res = None_val;
  }
  // run memprof callbacks both for the option we are allocating here
  // and the calling function.
  caml_process_pending_actions();
  CAMLreturn(res);
}

CAMLexport int caml_ephemeron_get_key (value ar, mlsize_t offset, value *key)
{
  value elt;
  CAMLassert_valid_offset(ar, offset);

  offset += CAML_EPHE_FIRST_KEY;

  if (is_ephe_key_none(ar, offset)){
    return 0;
  }else{
    elt = Field (ar, offset);
    if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
      caml_darken (elt, NULL);
    }
    *key = elt;
    CAMLassert_not_dead_value(elt);
    return 1;
  }
}

CAMLprim value caml_ephe_get_key (value ar, value n)
{
  value data;
  return optionalize(caml_ephemeron_get_key(ar, Long_val(n), &data), &data);
}

CAMLprim value caml_weak_get (value ar, value n)
{
  return caml_ephe_get_key(ar, n);
}

CAMLexport int caml_ephemeron_get_data (value ar, value *data)
{
  value elt;
  CAMLassert_valid_ephemeron(ar);

  if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
  elt = Field (ar, CAML_EPHE_DATA_OFFSET);
  if (elt == caml_ephe_none){
    return 0;
  }else{
    if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(elt)){
      caml_darken (elt, NULL);
    }
    *data = elt;
    CAMLassert_not_dead_value(elt);
    return 1;
  }
}

CAMLprim value caml_ephe_get_data (value ar)
{
  value data;
  return optionalize(caml_ephemeron_get_data(ar, &data), &data);
}


Caml_inline void copy_value(value src, value dst)
{
  if (Tag_val (src) < No_scan_tag){
    mlsize_t i;
    for (i = 0; i < Wosize_val (src); i++){
      value f = Field (src, i);
      if (caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(f)){
        caml_darken (f, NULL);
      }
      caml_modify (&Field (dst, i), f);
    }
  }else{
    memmove (Bp_val (dst), Bp_val (src), Bosize_val (src));
  }
}

CAMLexport int caml_ephemeron_get_key_copy(value ar, mlsize_t offset,
                                           value *key)
{
  mlsize_t loop = 0, infix_offs;
  CAMLparam1(ar);
  value elt = Val_unit, v; /* Caution: they are NOT local roots. */
  CAMLassert_valid_offset(ar, offset);

  offset += CAML_EPHE_FIRST_KEY;

  while(1) {
    if(is_ephe_key_none(ar, offset)) CAMLreturn(0);
    v = Field (ar, offset);
    /** Don't copy custom_block #7279 */
    if(!(Is_block (v) && Is_in_value_area(v) && Tag_val(v) != Custom_tag)) {
      if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){
        caml_darken (v, NULL);
      };
      *key = v;
      CAMLreturn(1);
    }
    infix_offs = Tag_val(v) == Infix_tag ? Infix_offset_val(v) : 0;
    v -= infix_offs;
    if (elt != Val_unit &&
        Wosize_val(v) == Wosize_val(elt) && Tag_val(v) == Tag_val(elt)) {
      /* The allocation may trigger a finaliser that change the tag
         and size of the block. Therefore, in addition to checking
         that the pointer is still alive, we have to check that it
         still has the same tag and size.
       */
      CAMLassert_not_dead_value(v);
      copy_value(v, elt);
      *key = elt + infix_offs;
      CAMLreturn(1);
    }

    CAMLassert(loop < 10);
    if(8 == loop){ /** One minor gc must be enough */
      elt = Val_unit;
      CAML_EV_COUNTER (EV_C_FORCE_MINOR_WEAK, 1);
      caml_minor_collection ();
    } else {
      /* cases where loop is between 0 to 7 and where loop is equal to 9 */
      elt = caml_alloc (Wosize_val (v), Tag_val (v));
      /* The GC may erase, move or even change v during this call to
         caml_alloc. */
    }
    ++loop;
  }
}

CAMLprim value caml_ephe_get_key_copy (value ar, value n)
{
  value key;
  int status = caml_ephemeron_get_key_copy(ar, Long_val(n), &key);
  return optionalize(status, &key);
}

CAMLprim value caml_weak_get_copy (value ar, value n)
{
  return caml_ephe_get_key_copy(ar, n);
}

CAMLexport int caml_ephemeron_get_data_copy (value ar, value *data)
{
  mlsize_t loop = 0, infix_offs;
  CAMLparam1 (ar);
  value elt = Val_unit, v; /* Caution: they are NOT local roots. */
  CAMLassert_valid_ephemeron(ar);

  while(1) {
    if (caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
    v = Field (ar, CAML_EPHE_DATA_OFFSET);
    if (v == caml_ephe_none) CAMLreturn(0);
    /** Don't copy custom_block #7279 */
    if (!(Is_block (v) && Is_in_value_area(v) && Tag_val(v) != Custom_tag)) {
      if ( caml_gc_phase == Phase_mark && Must_be_Marked_during_mark(v) ){
        caml_darken (v, NULL);
      };
      *data = v;
      CAMLreturn(1);
    }
    infix_offs = Tag_val(v) == Infix_tag ? Infix_offset_val(v) : 0;
    v -= infix_offs;
    if (elt != Val_unit &&
        Wosize_val(v) == Wosize_val(elt) && Tag_val(v) == Tag_val(elt)) {
      /** cf caml_ephemeron_get_key_copy */
      CAMLassert_not_dead_value(v);
      copy_value(v, elt);
      *data = elt + infix_offs;
      CAMLreturn(1);
    }

    CAMLassert(loop < 10);
    if(8 == loop){ /** One minor gc must be enough */
      elt = Val_unit;
      CAML_EV_COUNTER (EV_C_FORCE_MINOR_WEAK, 1);
      caml_minor_collection ();
    } else {
      /* cases where loop is between 0 to 7 and where loop is equal to 9 */
      elt = caml_alloc (Wosize_val (v), Tag_val (v));
      /** cf caml_ephemeron_get_key_copy */
    }
    ++loop;
  }
}


CAMLprim value caml_ephe_get_data_copy (value ar)
{
  value data;
  int status = caml_ephemeron_get_data_copy(ar, &data);
  return optionalize(status, &data);
}

CAMLexport int caml_ephemeron_key_is_set(value ar, mlsize_t offset)
{
  CAMLassert_valid_offset(ar, offset);

  offset += CAML_EPHE_FIRST_KEY;
  return !is_ephe_key_none(ar, offset);
}

CAMLprim value caml_ephe_check_key (value ar, value n)
{
  return Val_bool (caml_ephemeron_key_is_set(ar, Long_val(n)));
}

CAMLprim value caml_weak_check (value ar, value n)
{
  return caml_ephe_check_key(ar, n);
}

CAMLexport int caml_ephemeron_data_is_set (value ar)
{
  CAMLassert_valid_ephemeron(ar);

  if(caml_gc_phase == Phase_clean) caml_ephe_clean(ar);
  return Field (ar, CAML_EPHE_DATA_OFFSET) != caml_ephe_none;
}

CAMLprim value caml_ephe_check_data (value ar)
{
  return Val_bool (caml_ephemeron_data_is_set(ar));
}

CAMLexport void caml_ephemeron_blit_key(value ars, mlsize_t offset_s,
                                        value ard, mlsize_t offset_d,
                                        mlsize_t length)
{
  intnat i; /** intnat because the second for-loop stops with i == -1 */
  if (length == 0) return;
  CAMLassert_valid_offset(ars, offset_s);
  CAMLassert_valid_offset(ard, offset_d);
  CAMLassert(length <= Wosize_val(ars) - CAML_EPHE_FIRST_KEY);
  CAMLassert(length <= Wosize_val(ard) - CAML_EPHE_FIRST_KEY);
  CAMLassert(offset_s <= Wosize_val(ars) - CAML_EPHE_FIRST_KEY - length);
  CAMLassert(offset_d <= Wosize_val(ard) - CAML_EPHE_FIRST_KEY - length);

  offset_s += CAML_EPHE_FIRST_KEY;
  offset_d += CAML_EPHE_FIRST_KEY;

  if (caml_gc_phase == Phase_clean){
    caml_ephe_clean_partial(ars, offset_s, offset_s + length);
    /* We don't need to clean the keys that are about to be overwritten,
       except where cleaning them could result in releasing the data,
       which can't happen if data is already released. */
    if (Field (ard, CAML_EPHE_DATA_OFFSET) != caml_ephe_none)
      caml_ephe_clean_partial(ard, offset_d, offset_d + length);
  }
  if (offset_d < offset_s){
    for (i = 0; i < length; i++){
      do_set (ard, offset_d + i, Field (ars, offset_s + i));
    }
  }else{
    for (i = length - 1; i >= 0; i--){
      do_set (ard, offset_d + i,  Field (ars, offset_s + i));
    }
  }
}

CAMLprim value caml_ephe_blit_key (value ars, value ofs,
                                   value ard, value ofd, value len)
{
  if (Long_val(len) == 0) return Val_unit;

  caml_ephemeron_blit_key(ars,Long_val(ofs),ard,Long_val(ofd),Long_val(len));
  return Val_unit;
}

CAMLprim value caml_weak_blit (value ars, value ofs,
                      value ard, value ofd, value len)
{
  return caml_ephe_blit_key (ars, ofs, ard, ofd, len);
}

CAMLexport void caml_ephemeron_blit_data (value ars, value ard)
{
  CAMLassert_valid_ephemeron(ars);
  CAMLassert_valid_ephemeron(ard);

  if(caml_gc_phase == Phase_clean) {
    caml_ephe_clean(ars);
    caml_ephe_clean(ard);
  };
  do_set (ard, CAML_EPHE_DATA_OFFSET, Field (ars, CAML_EPHE_DATA_OFFSET));
}

CAMLprim value caml_ephe_blit_data (value ars, value ard)
{
  caml_ephemeron_blit_data(ars, ard);
  return Val_unit;
}