CAMLexport char * caml_format_exception_r(CAML_R, value exn)
{
  mlsize_t start, i;
  value bucket, v;
  struct stringbuf buf;
  char intbuf[64];
  char * res;

  buf.ptr = buf.data;
  buf.end = buf.data + sizeof(buf.data) - 1;
  add_string(&buf, String_val(Field(Field(exn, 0), 0)));
  if (Wosize_val(exn) >= 2) {
    /* Check for exceptions in the style of Match_failure and Assert_failure */
    if (Wosize_val(exn) == 2 &&
        Is_block(Field(exn, 1)) &&
        Tag_val(Field(exn, 1)) == 0 &&
        caml_is_special_exception_r(ctx, Field(exn, 0))) {
      bucket = Field(exn, 1);
      start = 0;
    } else {
      bucket = exn;
      start = 1;
    }
    add_char(&buf, '(');
    for (i = start; i < Wosize_val(bucket); i++) {
      if (i > start) add_string(&buf, ", ");
      v = Field(bucket, i);
      if (Is_long(v)) {
        sprintf(intbuf, "%" ARCH_INTNAT_PRINTF_FORMAT "d", Long_val(v));
        add_string(&buf, intbuf);
      } else if (Tag_val(v) == String_tag) {
        add_char(&buf, '"');
        add_string(&buf, String_val(v));
        add_char(&buf, '"');
      } else {
        add_char(&buf, '_');
      }
    }
    add_char(&buf, ')');
  }
  *buf.ptr = 0;              /* Terminate string */
  i = buf.ptr - buf.data + 1;
  res = malloc(i);
  if (res == NULL) return NULL;
  memmove(res, buf.data, i);
  return res;
}

static intnat pool_sweep(struct caml_heap_state* local, pool** plist, sizeclass sz) {
  pool* a = *plist;
  if (!a) return 0;
  *plist = a->next;

  value* p = (value*)((char*)a + POOL_HEADER_SZ);
  value* end = (value*)a + POOL_WSIZE;
  mlsize_t wh = wsize_sizeclass[sz];
  int all_free = 1, all_used = 1;
  struct heap_stats* s = &local->stats;

  while (p + wh <= end) {
    header_t hd = (header_t)*p;
    if (hd == 0) {
      /* already on freelist */
      all_used = 0;
    } else if (Has_status_hd(hd, global.GARBAGE)) {
      Assert(Whsize_hd(hd) <= wh);
      /* add to freelist */
      p[0] = 0;
      p[1] = (value)a->next_obj;
      Assert(Is_block((value)p));
      a->next_obj = p;
      all_used = 0;
      /* update stats */
      s->pool_live_blocks--;
      s->pool_live_words -= Whsize_hd(hd);
      s->pool_frag_words -= (wh - Whsize_hd(hd));
    } else {
      /* still live */
      all_free = 0;
    }
    p += wh;
  }

  if (all_free) {
    pool_release(local, a, sz);
  } else {
    pool** list = all_used ? &local->full_pools[sz] : &local->avail_pools[sz];
    a->next = *list;
    *list = a;
  }

  return POOL_WSIZE;
}

CAMLprim value caml_install_signal_handler(value signal_number, value action)
{
  CAMLparam2 (signal_number, action);
  CAMLlocal1 (res);
  int sig, act, oldact;

  sig = caml_convert_signal_number(Int_val(signal_number));
  if (sig < 0 || sig >= NSIG)
    caml_invalid_argument("Sys.signal: unavailable signal");
  switch(action) {
  case Val_int(0):              /* Signal_default */
    act = 0;
    break;
  case Val_int(1):              /* Signal_ignore */
    act = 1;
    break;
  default:                      /* Signal_handle */
    act = 2;
    break;
  }
  oldact = caml_set_signal_action(sig, act);
  switch (oldact) {
  case 0:                       /* was Signal_default */
    res = Val_int(0);
    break;
  case 1:                       /* was Signal_ignore */
    res = Val_int(1);
    break;
  case 2:                       /* was Signal_handle */
    res = caml_alloc_small (1, 0);
    Field(res, 0) = Field(caml_signal_handlers, sig);
    break;
  default:                      /* error in caml_set_signal_action */
    caml_sys_error(NO_ARG);
  }
  if (Is_block(action)) {
    if (caml_signal_handlers == 0) {
      caml_signal_handlers = caml_alloc(NSIG, 0);
      caml_register_global_root(&caml_signal_handlers);
    }
    caml_modify(&Field(caml_signal_handlers, sig), Field(action, 0));
  }
  caml_process_pending_signals();
  CAMLreturn (res);
}

static value next_minor_block(caml_domain_state* domain_state, value curr_hp)
{
  mlsize_t wsz;
  header_t hd;
  value curr_val;
  CAMLassert ((value)domain_state->young_ptr <= curr_hp);
  CAMLassert (curr_hp < (value)domain_state->young_end);
  hd = Hd_hp(curr_hp);
  curr_val = Val_hp(curr_hp);
  if (hd == 0) {
    /* Forwarded object, find the promoted version */
    curr_val = Op_val(curr_val)[0];
  }
  CAMLassert (Is_block(curr_val) && Hd_val(curr_val) != 0 && Tag_val(curr_val) != Infix_tag);
  wsz = Wosize_val(curr_val);
  CAMLassert (wsz <= Max_young_wosize);
  return curr_hp + Bsize_wsize(Whsize_wosize(wsz));
}

/*
 * Compute the size of the argument (of type TkArgs).
 * TkTokenList must be expanded,
 * TkQuote count for one.
 */
int argv_size(value v)
{
  switch (Tag_val(v)) {
  case 0:                       /* TkToken */
    return 1;
  case 1:                       /* TkTokenList */
    { int n = 0;
      value l;
      for (l=Field(v,0), n=0; Is_block(l); l=Field(l,1))
        n+=argv_size(Field(l,0));
      return n;
    }
  case 2:                       /* TkQuote */
    return 1;
  default:
    tk_error("argv_size: illegal tag");
  }
}

/* Test if the ephemeron is alive */
static inline int ephe_check_alive_data (struct caml_ephe_ref_elt *re,
                                         char* young_ptr, char* young_end)
{
  mlsize_t i;
  value child;

  for (i = CAML_EPHE_FIRST_KEY; i < Wosize_val(re->ephe); i++) {
    child = Op_val(re->ephe)[i];
    if (child != caml_ephe_none
        && Is_block (child) && is_in_interval(child, young_ptr, young_end)) {
      resolve_infix_val(&child);
      if (Hd_val(child) != 0) {
        /* value not copied to major heap */
        return 0;
      }
    }
  }
  return 1;
}

CAMLprim value unix_error_message(value err)
{
  int errnum;
  char buffer[512];

  errnum = Is_block(err) ? Int_val(Field(err, 0)) : error_table[Int_val(err)];
  if (errnum > 0)
    return copy_string(strerror(errnum));
  if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM | FORMAT_MESSAGE_IGNORE_INSERTS,
                    NULL,
                    -errnum,
                    0,
                    buffer,
                    sizeof(buffer),
                    NULL))
    return copy_string(buffer);
  sprintf(buffer, "unknown error #%d", errnum);
  return copy_string(buffer);
}

/* Make sure the minor heap is empty by performing a minor collection
   if needed.
*/
void caml_empty_minor_heap (void)
{
  value **r;

  if (caml_young_ptr != caml_young_end){
    caml_in_minor_collection = 1;
    caml_gc_message (0x02, "<", 0);
    caml_oldify_local_roots();
    for (r = caml_ref_table.base; r < caml_ref_table.ptr; r++){
      caml_oldify_one (**r, *r);
    }
    caml_oldify_mopup ();
    for (r = caml_weak_ref_table.base; r < caml_weak_ref_table.ptr; r++){
      if (Is_block (**r) && Is_young (**r)){
        if (Hd_val (**r) == 0){
          **r = Field (**r, 0);
        }else{
          **r = caml_weak_none;
        }
      }
    }
    if (caml_young_ptr < caml_young_start) caml_young_ptr = caml_young_start;
    caml_stat_minor_words += Wsize_bsize (caml_young_end - caml_young_ptr);
    caml_young_ptr = caml_young_end;
    caml_young_limit = caml_young_start;
    clear_table (&caml_ref_table);
    clear_table (&caml_weak_ref_table);
    caml_gc_message (0x02, ">", 0);
    caml_in_minor_collection = 0;
  }
  caml_final_empty_young ();
#ifdef DEBUG
  {
    value *p;
    for (p = (value *) caml_young_start; p < (value *) caml_young_end; ++p){
      *p = Debug_free_minor;
    }
    ++ minor_gc_counter;
  }
#endif
}

CAMLexport value caml_promote(struct domain* domain, value root)
{
  struct promotion_stack stk = {0};

  if (Is_long(root))
    /* Integers are already shared */
    return root;

  if (Tag_val(root) == Stack_tag)
    /* Stacks are handled specially */
    return promote_stack(domain, root);

  if (!Is_minor(root))
    /* This value is already shared */
    return root;

  Assert(caml_owner_of_young_block(root) == domain);

  value ret = caml_promote_one(&stk, domain, root);

  while (stk.sp > 0) {
    struct promotion_stack_entry* curr = &stk.stack[stk.sp - 1];
    value local = curr->local;
    value global = curr->global;
    int field = curr->field;
    Assert(field < Wosize_val(local));
    curr->field++;
    if (curr->field == Wosize_val(local))
      stk.sp--;
    value x = Op_val(local)[field];
    if (Is_block(x) && Tag_val(x) == Stack_tag) {
      /* stacks are not promoted unless explicitly requested */
      Ref_table_add(&domain->state->remembered_set->ref, global, field);
    } else {
      x = caml_promote_one(&stk, domain, x);
    }
    Op_val(local)[field] = Op_val(global)[field] = x;
  }
  caml_stat_free(stk.stack);
  return ret;
}

CAMLprim value netsys_mknod (value name, value perm, value nt)
{
#ifdef _WIN32
    invalid_argument("Netsys_posix.mknod not available");
#else
    mode_t m;
    dev_t d;
    int e;

    m = Long_val(perm) & 07777;
    d = 0;
    if (Is_block(nt)) {
	switch (Tag_val(nt)) {
	case 0:  /* = S_IFCHR */
	    m |= S_IFCHR;
	    d = Long_val(Field(nt,0));
	    break;
	case 1:  /* = S_IFBLK */
	    m |= S_IFBLK;
	    d = Long_val(Field(nt,0));
	    break;
	}
    }
    else {
	switch (Long_val(nt)) {
	case 0:  /* = S_IFREG */
	    m |= S_IFREG; break;
	case 1:  /* = S_IFIFO */
	    m |= S_IFIFO; break;
	case 2:  /* = S_IFSOCK */
	    m |= S_IFSOCK; break;
	}

    }

    e = mknod(String_val(name), m, d);
    if (e < 0) uerror("mknod", Nothing);

    return Val_unit;
#endif
}

CAMLprim value ml_gsl_monte_vegas_set_params(value state, value params)
{
    gsl_monte_vegas_state *s = GSLVEGASSTATE_VAL(state);
    s->alpha      = Double_val(Field(params, 0));
    s->iterations = Int_val(Field(params, 1));
    s->stage      = Int_val(Field(params, 2));
    s->mode       = Int_val(Field(params, 3)) - 1;
    s->verbose    = Int_val(Field(params, 4));
    {
        value vchan = Field(params, 5);
        if(Is_block(vchan)) {
            struct channel *chan=Channel(Field(vchan, 0));
            if(s->ostream != stdout && s->ostream != stderr)
                fclose(s->ostream);
            flush(chan);
            s->ostream = fdopen(dup(chan->fd), "w");
            GSLVEGASSTREAM_VAL(state) = vchan;
        }
    }
    return Val_unit;
}

CAMLprim value caml_weak_get (value ar, value n)
{
  CAMLparam2 (ar, n);
  mlsize_t offset = Long_val (n) + 1;
  CAMLlocal2 (res, elt);
                                                   Assert (Is_in_heap (ar));
  if (offset < 1 || offset >= Wosize_val (ar)){
    caml_invalid_argument ("Weak.get");
  }
  if (Field (ar, offset) == caml_weak_none){
    res = None_val;
  }else{
    elt = Field (ar, offset);
    if (caml_gc_phase == Phase_mark && Is_block (elt) && Is_in_heap (elt)){
      caml_darken (elt, NULL);
    }
    res = caml_alloc_small (1, Some_tag);
    Field (res, 0) = elt;
  }
  CAMLreturn (res);
}

CAMLexport value
unix_setsockopt_aux(char * name,
                    enum option_type ty, int level, int option,
                    value socket, value val)
{
  union option_value optval;
  socklen_param_type optsize;
  double f;

  switch (ty) {
  case TYPE_BOOL:
  case TYPE_INT:
    optsize = sizeof(optval.i);
    optval.i = Int_val(val);
    break;
  case TYPE_LINGER:
    optsize = sizeof(optval.lg);
    optval.lg.l_onoff = Is_block (val);
    if (optval.lg.l_onoff)
      optval.lg.l_linger = Int_val (Field (val, 0));
    break;
  case TYPE_TIMEVAL:
    f = Double_val(val);
    optsize = sizeof(optval.tv);
    optval.tv.tv_sec = (int) f;
    optval.tv.tv_usec = (int) (1e6 * (f - optval.tv.tv_sec));
    break;
  case TYPE_UNIX_ERROR:
  default:
    unix_error(EINVAL, name, Nothing);
  }

  if (setsockopt(Int_val(socket), level, option,
                 (void *) &optval, optsize) == -1)
    uerror(name, Nothing);

  return Val_unit;
}

/* Check that [v]'s header looks good.  [v] must be a block in the heap. */
static void check_head (value v)
{
  Assert (Is_block (v));
  Assert (Is_in_heap (v));

  Assert (Wosize_val (v) != 0);
  Assert (Color_hd (Hd_val (v)) != Caml_blue);
  Assert (Is_in_heap (v));
  if (Tag_val (v) == Infix_tag){
    int offset = Wsize_bsize (Infix_offset_val (v));
    value trueval = Val_op (&Field (v, -offset));
    Assert (Tag_val (trueval) == Closure_tag);
    Assert (Wosize_val (trueval) > offset);
    Assert (Is_in_heap (&Field (trueval, Wosize_val (trueval) - 1)));
  }else{
    Assert (Is_in_heap (&Field (v, Wosize_val (v) - 1)));
  }
  if (Tag_val (v) ==  Double_tag){
    Assert (Wosize_val (v) == Double_wosize);
  }else if (Tag_val (v) == Double_array_tag){
    Assert (Wosize_val (v) % Double_wosize == 0);
  }
}

CAMLprim value ocaml_f0r_update(value plugin, value instance, value time, value inframe, value outframe)
{
  CAMLparam5(plugin, instance, time, inframe, outframe);
  f0r_instance_t *i = Instance_val(instance);
  plugin_t *p = Plugin_val(plugin);
  double t = Double_val(time);
  const uint32_t *in;
  uint32_t *out = Caml_ba_data_val(outframe);

  if (Is_block(inframe))
    in = Caml_ba_data_val(Field(inframe,0));
  else
    in = NULL;

  caml_release_runtime_system();
  if (p->update)
    p->update(i, t, in, out);
  else
    p->update2(i, t, in, NULL, NULL, out);
  caml_acquire_runtime_system();

  CAMLreturn(Val_unit);
}

CAMLprim value caml_weak_blit (value ars, value ofs,
                               value ard, value ofd, value len)
{
    mlsize_t offset_s = Long_val (ofs) + 1;
    mlsize_t offset_d = Long_val (ofd) + 1;
    mlsize_t length = Long_val (len);
    long i;
    Assert (Is_in_heap (ars));
    Assert (Is_in_heap (ard));
    if (offset_s < 1 || offset_s + length > Wosize_val (ars)) {
        caml_invalid_argument ("Weak.blit");
    }
    if (offset_d < 1 || offset_d + length > Wosize_val (ard)) {
        caml_invalid_argument ("Weak.blit");
    }
    if (caml_gc_phase == Phase_mark && caml_gc_subphase == Subphase_weak1) {
        /* OCamlCC: fix g++ warning */
        for (i = 0; (mlsize_t) i < length; i++) {
            value v = Field (ars, offset_s + i);
            if (v != caml_weak_none && Is_block (v) && Is_in_heap (v)
                    && Is_white_val (v)) {
                Field (ars, offset_s + i) = caml_weak_none;
            }
        }
    }
    if (offset_d < offset_s) {
        /* OCamlCC: fix g++ warning */
        for (i = 0; (mlsize_t) 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));
        }
    }
    return Val_unit;
}

static void check_block (char *hp)
{
    mlsize_t i;
    value v = Val_hp (hp);
    value f;

    check_head (v);
    switch (Tag_hp (hp)) {
    case Abstract_tag:
        break;
    case String_tag:
        break;
    case Double_tag:
        Assert (Wosize_val (v) == Double_wosize);
        break;
    case Double_array_tag:
        Assert (Wosize_val (v) % Double_wosize == 0);
        break;
    case Custom_tag:
        Assert (!Is_in_heap (Custom_ops_val (v)));
        break;

    case Infix_tag:
        Assert (0);
        break;

    default:
        Assert (Tag_hp (hp) < No_scan_tag);
        for (i = 0; i < Wosize_hp (hp); i++) {
            f = Field (v, i);
            if (Is_block (f) && Is_in_heap (f)) {
                check_head (f);
                Assert (Color_val (f) != Caml_blue);
            }
        }
    }
}

static alpm_list_t * build_alpm_list ( value list,
                                       caml_elem_conv converter,
                                       alpm_list_t **last )
{
    alpm_list_t * elem, * next;

    if ( Is_block( list )) {
        elem = malloc( sizeof( alpm_list_t ));
        elem->prev = NULL;
        elem->data = (*converter)( Field( list, 0 ));

        next = caml_to_alpm_list( Field( list, 1 ), converter );
        elem->next = next;

        if ( next == NULL ) *last = elem;
        else next->prev = elem;
    }
    else {
        /* Field 0 of the block list should be 0. */
        elem = NULL;
    }

    return elem;
}

CAMLprim value ocaml_gstreamer_bus_timed_pop_filtered(value _bus, value _timeout, value _filter)
{
  CAMLparam3(_bus, _timeout, _filter);
  CAMLlocal1(ans);
  GstBus *bus = Bus_val(_bus);
  GstClockTime timeout = GST_CLOCK_TIME_NONE;
  GstMessageType filter = 0;
  GstMessage *msg;
  int i;

  if (Is_block(_timeout)) {
    timeout = (GstClockTime)Int64_val(Field(_timeout, 0));
  }

  for(i = 0; i < Wosize_val(_filter); i++)
    filter |= message_type_of_int(Int_val(Field(_filter, i)));

  caml_release_runtime_system();
  msg = gst_bus_timed_pop_filtered(bus, timeout, filter);
  caml_acquire_runtime_system();

  if (!msg) caml_raise_constant(*caml_named_value("gstreamer_exn_timeout"));
  CAMLreturn(value_of_message(msg));
}

CAMLexport void caml_modify_generational_global_root_r(CAML_R, value *r, value newval)
{
  value oldval = *r;

  /* It is OK to have a root in roots_young that suddenly points to
     the old generation -- the next minor GC will take care of that.
     What needs corrective action is a root in roots_old that suddenly
     points to the young generation. */
  if (Is_block(newval) && Is_young(newval) &&
      Is_block(oldval) && Is_in_heap(oldval)) {
    caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
    caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
  }
  /* PR#4704 */
  else if (!Is_block(oldval) && Is_block(newval)) {
    /* The previous value in the root was unboxed but now it is boxed.
       The root won't appear in any of the root lists thus far (by virtue
       of the operation of [caml_register_generational_global_root]), so we
       need to make sure it gets in, or else it will never be scanned. */
    if (Is_young(newval))
      caml_insert_global_root_r(ctx, &caml_global_roots_young, r);
    else if (Is_in_heap(newval))
      caml_insert_global_root_r(ctx, &caml_global_roots_old, r);
  }
  else if (Is_block(oldval) && !Is_block(newval)) {
    /* The previous value in the root was boxed but now it is unboxed, so
       the root should be removed. If [oldval] is young, this will happen
       anyway at the next minor collection, but it is safer to delete it
       here. */
    if (Is_young(oldval))
      caml_delete_global_root_r(ctx, &caml_global_roots_young, r);
    else if (Is_in_heap(oldval))
      caml_delete_global_root_r(ctx, &caml_global_roots_old, r);
  }
  /* end PR#4704 */
  *r = newval;
}