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;
}
/* Make sure the minor heap is empty by performing a minor collection if
* needed. */
void caml_empty_minor_heap (void)
{
uintnat minor_allocated_bytes = caml_domain_state->young_end - caml_domain_state->young_ptr;
unsigned rewritten = 0;
struct caml_ref_entry *r;
caml_save_stack_gc();
stat_live_bytes = 0;
if (minor_allocated_bytes != 0){
caml_gc_log ("Minor collection starting");
caml_do_local_roots(&caml_oldify_one, caml_domain_self());
for (r = caml_domain_state->remembered_set->ref.base; r < caml_domain_state->remembered_set->ref.ptr; r++){
value x;
caml_oldify_one (Op_val(r->obj)[r->field], &x);
}
for (r = caml_domain_state->remembered_set->fiber_ref.base; r < caml_domain_state->remembered_set->fiber_ref.ptr; r++) {
caml_scan_dirty_stack(&caml_oldify_one, r->obj);
}
caml_oldify_mopup ();
for (r = caml_domain_state->remembered_set->ref.base; r < caml_domain_state->remembered_set->ref.ptr; r++){
value v = Op_val(r->obj)[r->field];
if (Is_block(v) && Is_young(v)) {
Assert (Hp_val (v) >= caml_domain_state->young_ptr);
value vnew;
header_t hd = Hd_val(v);
// FIXME: call oldify_one here?
if (Is_promoted_hd(hd)) {
vnew = caml_addrmap_lookup(&caml_domain_state->remembered_set->promotion, v);
} else {
int offset = 0;
if (Tag_hd(hd) == Infix_tag) {
offset = Infix_offset_hd(hd);
v -= offset;
}
Assert (Hd_val (v) == 0);
vnew = Op_val(v)[0] + offset;
}
Assert(Is_block(vnew) && !Is_young(vnew));
Assert(Hd_val(vnew));
if (Tag_hd(hd) == Infix_tag) { Assert(Tag_val(vnew) == Infix_tag); }
rewritten += caml_atomic_cas_field(r->obj, r->field, v, vnew);
}
}
caml_addrmap_iter(&caml_domain_state->remembered_set->promotion, unpin_promoted_object);
if (caml_domain_state->young_ptr < caml_domain_state->young_start)
caml_domain_state->young_ptr = caml_domain_state->young_start;
caml_stat_minor_words += Wsize_bsize (minor_allocated_bytes);
caml_domain_state->young_ptr = caml_domain_state->young_end;
clear_table (&caml_domain_state->remembered_set->ref);
caml_addrmap_clear(&caml_domain_state->remembered_set->promotion);
caml_addrmap_clear(&caml_domain_state->remembered_set->promotion_rev);
caml_gc_log ("Minor collection completed: %u of %u kb live, %u pointers rewritten",
(unsigned)stat_live_bytes/1024, (unsigned)minor_allocated_bytes/1024, rewritten);
}
for (r = caml_domain_state->remembered_set->fiber_ref.base; r < caml_domain_state->remembered_set->fiber_ref.ptr; r++) {
caml_scan_dirty_stack(&caml_darken, r->obj);
caml_clean_stack(r->obj);
}
clear_table (&caml_domain_state->remembered_set->fiber_ref);
caml_restore_stack_gc();
#ifdef DEBUG
{
value *p;
for (p = (value *) caml_domain_state->young_start;
p < (value *) caml_domain_state->young_end; ++p){
*p = Debug_free_minor;
}
++ minor_gc_counter;
}
#endif
}
CAMLprim value caml_parse_engine(struct parser_tables *tables,
struct parser_env *env, value cmd, value arg)
{
int state;
mlsize_t sp, asp;
int errflag;
int n, n1, n2, m, state1;
switch(Int_val(cmd)) {
case START:
state = 0;
sp = Int_val(env->sp);
errflag = 0;
loop:
n = Short(tables->defred, state);
if (n != 0) goto reduce;
if (Int_val(env->curr_char) >= 0) goto testshift;
SAVE;
return READ_TOKEN;
/* The ML code calls the lexer and updates */
/* symb_start and symb_end */
case TOKEN_READ:
RESTORE;
if (Is_block(arg)) {
env->curr_char = Field(tables->transl_block, Tag_val(arg));
caml_modify(&env->lval, Field(arg, 0));
} else {
env->curr_char = Field(tables->transl_const, Int_val(arg));
caml_modify(&env->lval, Val_long(0));
}
if (caml_parser_trace) print_token(tables, state, arg);
testshift:
n1 = Short(tables->sindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) goto shift;
n1 = Short(tables->rindex, state);
n2 = n1 + Int_val(env->curr_char);
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == Int_val(env->curr_char)) {
n = Short(tables->table, n2);
goto reduce;
}
if (errflag > 0) goto recover;
SAVE;
return CALL_ERROR_FUNCTION;
/* The ML code calls the error function */
case ERROR_DETECTED:
RESTORE;
recover:
if (errflag < 3) {
errflag = 3;
while (1) {
state1 = Int_val(Field(env->s_stack, sp));
n1 = Short(tables->sindex, state1);
n2 = n1 + ERRCODE;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == ERRCODE) {
if (caml_parser_trace)
#ifdef _KERNEL
printf("Recovering in state %d\n", state1);
#else
fprintf(stderr, "Recovering in state %d\n", state1);
#endif
goto shift_recover;
} else {
if (caml_parser_trace){
#ifdef _KERNEL
printf("Discarding state %d\n", state1);
#else
fprintf(stderr, "Discarding state %d\n", state1);
#endif
}
if (sp <= Int_val(env->stackbase)) {
if (caml_parser_trace){
#ifdef _KERNEL
printf("No more states to discard\n");
#else
fprintf(stderr, "No more states to discard\n");
#endif
}
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
}
sp--;
}
}
} else {
if (Int_val(env->curr_char) == 0)
return RAISE_PARSE_ERROR; /* The ML code raises Parse_error */
#ifdef _KERNEL
if (caml_parser_trace) printf("Discarding last token read\n");
#else
if (caml_parser_trace) fprintf(stderr, "Discarding last token read\n");
#endif
env->curr_char = Val_int(-1);
goto loop;
}
shift:
env->curr_char = Val_int(-1);
if (errflag > 0) errflag--;
shift_recover:
if (caml_parser_trace)
#ifdef _KERNEL
printf("State %d: shift to state %d\n",
state, Short(tables->table, n2));
#else
fprintf(stderr, "State %d: shift to state %d\n",
state, Short(tables->table, n2));
#endif
state = Short(tables->table, n2);
sp++;
if (sp < Long_val(env->stacksize)) goto push;
SAVE;
return GROW_STACKS_1;
/* The ML code resizes the stacks */
case STACKS_GROWN_1:
RESTORE;
push:
Field(env->s_stack, sp) = Val_int(state);
caml_modify(&Field(env->v_stack, sp), env->lval);
Store_field (env->symb_start_stack, sp, env->symb_start);
Store_field (env->symb_end_stack, sp, env->symb_end);
goto loop;
reduce:
if (caml_parser_trace)
#ifdef _KERNEL
printf("State %d: reduce by rule %d\n", state, n);
#else
fprintf(stderr, "State %d: reduce by rule %d\n", state, n);
#endif
m = Short(tables->len, n);
env->asp = Val_int(sp);
env->rule_number = Val_int(n);
env->rule_len = Val_int(m);
sp = sp - m + 1;
m = Short(tables->lhs, n);
state1 = Int_val(Field(env->s_stack, sp - 1));
n1 = Short(tables->gindex, m);
n2 = n1 + state1;
if (n1 != 0 && n2 >= 0 && n2 <= Int_val(tables->tablesize) &&
Short(tables->check, n2) == state1) {
state = Short(tables->table, n2);
} else {
state = Short(tables->dgoto, m);
}
if (sp < Long_val(env->stacksize)) goto semantic_action;
SAVE;
return GROW_STACKS_2;
/* The ML code resizes the stacks */
case STACKS_GROWN_2:
RESTORE;
semantic_action:
SAVE;
return COMPUTE_SEMANTIC_ACTION;
/* The ML code calls the semantic action */
case SEMANTIC_ACTION_COMPUTED:
RESTORE;
Field(env->s_stack, sp) = Val_int(state);
caml_modify(&Field(env->v_stack, sp), arg);
asp = Int_val(env->asp);
Store_field (env->symb_end_stack, sp, Field(env->symb_end_stack, asp));
if (sp > asp) {
/* This is an epsilon production. Take symb_start equal to symb_end. */
Store_field (env->symb_start_stack, sp, Field(env->symb_end_stack, asp));
}
goto loop;
default: /* Should not happen */
Assert(0);
return RAISE_PARSE_ERROR; /* Keeps gcc -Wall happy */
}
}
static void hash_aux(value obj)
{
unsigned char * p;
mlsize_t i, j;
tag_t tag;
hash_univ_limit--;
if (hash_univ_count < 0 || hash_univ_limit < 0) return;
again:
if (Is_long(obj)) {
hash_univ_count--;
Combine(Long_val(obj));
return;
}
/* Pointers into the heap are well-structured blocks. So are atoms.
We can inspect the block contents. */
Assert (Is_block (obj));
if (Is_in_value_area(obj)) {
tag = Tag_val(obj);
switch (tag) {
case String_tag:
hash_univ_count--;
i = caml_string_length(obj);
for (p = &Byte_u(obj, 0); i > 0; i--, p++)
Combine_small(*p);
break;
case Double_tag:
/* For doubles, we inspect their binary representation, LSB first.
The results are consistent among all platforms with IEEE floats. */
hash_univ_count--;
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, 0), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
break;
case Double_array_tag:
hash_univ_count--;
for (j = 0; j < Bosize_val(obj); j += sizeof(double)) {
#ifdef ARCH_BIG_ENDIAN
for (p = &Byte_u(obj, j + sizeof(double) - 1), i = sizeof(double);
i > 0;
p--, i--)
#else
for (p = &Byte_u(obj, j), i = sizeof(double);
i > 0;
p++, i--)
#endif
Combine_small(*p);
}
break;
case Abstract_tag:
/* We don't know anything about the contents of the block.
Better do nothing. */
break;
case Infix_tag:
hash_aux(obj - Infix_offset_val(obj));
break;
case Forward_tag:
obj = Forward_val (obj);
goto again;
case Object_tag:
hash_univ_count--;
Combine(Oid_val(obj));
break;
case Custom_tag:
/* If no hashing function provided, do nothing */
if (Custom_ops_val(obj)->hash != NULL) {
hash_univ_count--;
Combine(Custom_ops_val(obj)->hash(obj));
}
break;
default:
hash_univ_count--;
Combine_small(tag);
i = Wosize_val(obj);
while (i != 0) {
i--;
hash_aux(Field(obj, i));
}
break;
}
return;
}
/* Otherwise, obj is a pointer outside the heap, to an object with
a priori unknown structure. Use its physical address as hash key. */
Combine((intnat) obj);
}
CAMLprim value unix_error_message(value err)
{
int errnum;
errnum = Is_block(err) ? Int_field(err, 0) : error_table[Int_val(err)];
return caml_copy_string(strerror(errnum));
}
static void extern_rec(value v)
{
tailcall:
if (Is_long(v)) {
intnat n = Long_val(v);
if (n >= 0 && n < 0x40) {
Write(PREFIX_SMALL_INT + n);
} else if (n >= -(1 << 7) && n < (1 << 7)) {
writecode8(CODE_INT8, n);
} else if (n >= -(1 << 15) && n < (1 << 15)) {
writecode16(CODE_INT16, n);
#ifdef ARCH_SIXTYFOUR
} else if (n < -((intnat)1 << 31) || n >= ((intnat)1 << 31)) {
writecode64(CODE_INT64, n);
#endif
} else
writecode32(CODE_INT32, n);
return;
}
if (Is_in_value_area(v)) {
header_t hd = Hd_val(v);
tag_t tag = Tag_hd(hd);
mlsize_t sz = Wosize_hd(hd);
if (tag == Forward_tag) {
value f = Forward_val (v);
if (Is_block (f)
&& (!Is_in_value_area(f) || Tag_val (f) == Forward_tag
|| Tag_val (f) == Lazy_tag || Tag_val (f) == Double_tag)){
/* Do not short-circuit the pointer. */
}else{
v = f;
goto tailcall;
}
}
/* Atoms are treated specially for two reasons: they are not allocated
in the externed block, and they are automatically shared. */
if (sz == 0) {
if (tag < 16) {
Write(PREFIX_SMALL_BLOCK + tag);
} else {
writecode32(CODE_BLOCK32, hd);
}
return;
}
/* Check if already seen */
if (Color_hd(hd) == Caml_blue) {
uintnat d = obj_counter - (uintnat) Field(v, 0);
if (d < 0x100) {
writecode8(CODE_SHARED8, d);
} else if (d < 0x10000) {
writecode16(CODE_SHARED16, d);
} else {
writecode32(CODE_SHARED32, d);
}
return;
}
/* Output the contents of the object */
switch(tag) {
case String_tag: {
mlsize_t len = caml_string_length(v);
if (len < 0x20) {
Write(PREFIX_SMALL_STRING + len);
} else if (len < 0x100) {
writecode8(CODE_STRING8, len);
} else {
writecode32(CODE_STRING32, len);
}
writeblock(String_val(v), len);
size_32 += 1 + (len + 4) / 4;
size_64 += 1 + (len + 8) / 8;
extern_record_location(v);
break;
}
case Double_tag: {
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
Write(CODE_DOUBLE_NATIVE);
writeblock_float8((double *) v, 1);
size_32 += 1 + 2;
size_64 += 1 + 1;
extern_record_location(v);
break;
}
case Double_array_tag: {
mlsize_t nfloats;
if (sizeof(double) != 8)
extern_invalid_argument("output_value: non-standard floats");
nfloats = Wosize_val(v) / Double_wosize;
if (nfloats < 0x100) {
writecode8(CODE_DOUBLE_ARRAY8_NATIVE, nfloats);
} else {
writecode32(CODE_DOUBLE_ARRAY32_NATIVE, nfloats);
}
writeblock_float8((double *) v, nfloats);
size_32 += 1 + nfloats * 2;
size_64 += 1 + nfloats;
extern_record_location(v);
break;
}
case Abstract_tag:
extern_invalid_argument("output_value: abstract value (Abstract)");
break;
case Infix_tag:
writecode32(CODE_INFIXPOINTER, Infix_offset_hd(hd));
extern_rec(v - Infix_offset_hd(hd));
break;
case Custom_tag: {
uintnat sz_32, sz_64;
char * ident = Custom_ops_val(v)->identifier;
void (*serialize)(value v, uintnat * wsize_32,
uintnat * wsize_64)
= Custom_ops_val(v)->serialize;
if (serialize == NULL)
extern_invalid_argument("output_value: abstract value (Custom)");
Write(CODE_CUSTOM);
writeblock(ident, strlen(ident) + 1);
Custom_ops_val(v)->serialize(v, &sz_32, &sz_64);
size_32 += 2 + ((sz_32 + 3) >> 2); /* header + ops + data */
size_64 += 2 + ((sz_64 + 7) >> 3);
extern_record_location(v);
break;
}
default: {
value field0;
mlsize_t i;
if (tag < 16 && sz < 8) {
Write(PREFIX_SMALL_BLOCK + tag + (sz << 4));
#ifdef ARCH_SIXTYFOUR
} else if (hd >= ((uintnat)1 << 32)) {
writecode64(CODE_BLOCK64, Whitehd_hd (hd));
#endif
} else {
writecode32(CODE_BLOCK32, Whitehd_hd (hd));
}
size_32 += 1 + sz;
size_64 += 1 + sz;
field0 = Field(v, 0);
extern_record_location(v);
if (sz == 1) {
v = field0;
} else {
extern_rec(field0);
for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
v = Field(v, i);
}
goto tailcall;
}
}
}
else if ((char *) v >= caml_code_area_start &&
static void caml_oldify_one (value v, value *p)
{
value result;
header_t hd;
mlsize_t sz, i;
tag_t tag;
tail_call:
if (Is_block (v) && Is_young (v)){
Assert (Hp_val (v) >= caml_domain_state->young_ptr);
hd = Hd_val (v);
stat_live_bytes += Bhsize_hd(hd);
if (Is_promoted_hd (hd)) {
*p = caml_addrmap_lookup(&caml_domain_state->remembered_set->promotion, v);
} else if (hd == 0){ /* If already forwarded */
*p = Op_val(v)[0]; /* then forward pointer is first field. */
}else{
tag = Tag_hd (hd);
if (tag < Infix_tag){
value field0;
sz = Wosize_hd (hd);
result = alloc_shared (sz, tag);
*p = result;
if (tag == Stack_tag) {
memcpy((void*)result, (void*)v, sizeof(value) * sz);
Hd_val (v) = 0;
Op_val(v)[0] = result;
Op_val(v)[1] = oldify_todo_list;
oldify_todo_list = v;
} else {
field0 = Op_val(v)[0];
Hd_val (v) = 0; /* Set forward flag */
Op_val(v)[0] = result; /* and forward pointer. */
if (sz > 1){
Op_val (result)[0] = field0;
Op_val (result)[1] = oldify_todo_list; /* Add this block */
oldify_todo_list = v; /* to the "to do" list. */
}else{
Assert (sz == 1);
p = Op_val(result);
v = field0;
goto tail_call;
}
}
}else if (tag >= No_scan_tag){
sz = Wosize_hd (hd);
result = alloc_shared(sz, tag);
for (i = 0; i < sz; i++) Op_val (result)[i] = Op_val(v)[i];
Hd_val (v) = 0; /* Set forward flag */
Op_val (v)[0] = result; /* and forward pointer. */
*p = result;
}else if (tag == Infix_tag){
mlsize_t offset = Infix_offset_hd (hd);
caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */
*p += offset;
} else{
value f = Forward_val (v);
tag_t ft = 0;
int vv = 1;
Assert (tag == Forward_tag);
if (Is_block (f)){
if (Is_young (f)){
vv = 1;
ft = Tag_val (Hd_val (f) == 0 ? Op_val (f)[0] : f);
}else{
vv = 1;
if (vv){
ft = Tag_val (f);
}
}
}
if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
/* Do not short-circuit the pointer. Copy as a normal block. */
Assert (Wosize_hd (hd) == 1);
result = alloc_shared (1, Forward_tag);
*p = result;
Hd_val (v) = 0; /* Set (GC) forward flag */
Op_val (v)[0] = result; /* and forward pointer. */
p = Op_val (result);
v = f;
goto tail_call;
}else{
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
}else{
*p = v;
}
}
CAMLprim value unix_getaddrinfo(value vnode, value vserv, value vopts)
{
CAMLparam3(vnode, vserv, vopts);
CAMLlocal3(vres, v, e);
mlsize_t len;
char * node, * serv;
struct addrinfo hints;
struct addrinfo * res, * r;
int retcode;
/* Extract "node" parameter */
len = string_length(vnode);
if (len == 0) {
node = NULL;
} else {
node = stat_alloc(len + 1);
strcpy(node, String_val(vnode));
}
/* Extract "service" parameter */
len = string_length(vserv);
if (len == 0) {
serv = NULL;
} else {
serv = stat_alloc(len + 1);
strcpy(serv, String_val(vserv));
}
/* Parse options, set hints */
memset(&hints, 0, sizeof(hints));
hints.ai_family = PF_UNSPEC;
for (/*nothing*/; Is_block(vopts); vopts = Field(vopts, 1)) {
v = Field(vopts, 0);
if (Is_block(v))
switch (Tag_val(v)) {
case 0: /* AI_FAMILY of socket_domain */
hints.ai_family = socket_domain_table[Int_val(Field(v, 0))];
break;
case 1: /* AI_SOCKTYPE of socket_type */
hints.ai_socktype = socket_type_table[Int_val(Field(v, 0))];
break;
case 2: /* AI_PROTOCOL of int */
hints.ai_protocol = Int_val(Field(v, 0));
break;
}
else
switch (Int_val(v)) {
case 0: /* AI_NUMERICHOST */
hints.ai_flags |= AI_NUMERICHOST; break;
case 1: /* AI_CANONNAME */
hints.ai_flags |= AI_CANONNAME; break;
case 2: /* AI_PASSIVE */
hints.ai_flags |= AI_PASSIVE; break;
}
}
/* Do the call */
enter_blocking_section();
retcode = getaddrinfo(node, serv, &hints, &res);
leave_blocking_section();
if (node != NULL) stat_free(node);
if (serv != NULL) stat_free(serv);
/* Convert result */
vres = Val_int(0);
if (retcode == 0) {
for (r = res; r != NULL; r = r->ai_next) {
e = convert_addrinfo(r);
v = alloc_small(2, 0);
Field(v, 0) = e;
Field(v, 1) = vres;
vres = v;
}
freeaddrinfo(res);
}
CAMLreturn(vres);
}
void caml_oldify_one (value v, value *p)
{
value result;
header_t hd;
mlsize_t sz, i;
tag_t tag;
tail_call:
if (Is_block (v) && Is_young (v)){
if (Hp_val(v) < caml_young_ptr)
printf("%lx, %lx\n", Hp_val(v), caml_young_ptr);
Assert (Hp_val (v) >= caml_young_ptr);
hd = Hd_val (v);
if (hd == 0){ /* If already forwarded */
*p = Field (v, 0); /* then forward pointer is first field. */
}else{
tag = Tag_hd (hd);
if (tag < Infix_tag){
value field0;
sz = Wosize_hd (hd);
result = caml_alloc_shr (sz, tag);
*p = result;
field0 = Field (v, 0);
Hd_val (v) = 0; /* Set forward flag */
Field (v, 0) = result; /* and forward pointer. */
if (sz > 1){
Field (result, 0) = field0;
Field (result, 1) = oldify_todo_list; /* Add this block */
oldify_todo_list = v; /* to the "to do" list. */
}else{
Assert (sz == 1);
p = &Field (result, 0);
v = field0;
goto tail_call;
}
}else if (tag >= No_scan_tag){
sz = Wosize_hd (hd);
result = caml_alloc_shr (sz, tag);
for (i = 0; i < sz; i++) Field (result, i) = Field (v, i);
Hd_val (v) = 0; /* Set forward flag */
Field (v, 0) = result; /* and forward pointer. */
*p = result;
}else if (tag == Infix_tag){
mlsize_t offset = Infix_offset_hd (hd);
caml_oldify_one (v - offset, p); /* Cannot recurse deeper than 1. */
*p += offset;
}else{
value f = Forward_val (v);
tag_t ft = 0;
int vv = 1;
Assert (tag == Forward_tag);
if (Is_block (f)){
vv = Is_in_value_area(f);
if (vv) {
ft = Tag_val (Hd_val (f) == 0 ? Field (f, 0) : f);
}
}
if (!vv || ft == Forward_tag || ft == Lazy_tag || ft == Double_tag){
/* Do not short-circuit the pointer. Copy as a normal block. */
Assert (Wosize_hd (hd) == 1);
result = caml_alloc_shr (1, Forward_tag);
*p = result;
Hd_val (v) = 0; /* Set (GC) forward flag */
Field (v, 0) = result; /* and forward pointer. */
p = &Field (result, 0);
v = f;
goto tail_call;
}else{
v = f; /* Follow the forwarding */
goto tail_call; /* then oldify. */
}
}
}
}else{
*p = v;
}
}
int netsys_init_value_1(struct htab *t,
struct nqueue *q,
char *dest,
char *dest_end,
value orig,
int enable_bigarrays,
int enable_customs,
int enable_atoms,
int simulation,
void *target_addr,
struct named_custom_ops *target_custom_ops,
int color,
intnat *start_offset,
intnat *bytelen
)
{
void *orig_addr;
void *work_addr;
value work;
int work_tag;
char *work_header;
size_t work_bytes;
size_t work_words;
void *copy_addr;
value copy;
char *copy_header;
header_t copy_header1;
int copy_tag;
size_t copy_words;
void *fixup_addr;
char *dest_cur;
char *dest_ptr;
int code, i;
intnat addr_delta;
struct named_custom_ops *ops_ptr;
void *int32_target_ops;
void *int64_target_ops;
void *nativeint_target_ops;
void *bigarray_target_ops;
copy = 0;
dest_cur = dest;
addr_delta = ((char *) target_addr) - dest;
if (dest_cur >= dest_end && !simulation) return (-4); /* out of space */
if (!Is_block(orig)) return (-2);
orig_addr = (void *) orig;
code = netsys_queue_add(q, orig_addr);
if (code != 0) return code;
/* initialize *_target_ops */
bigarray_target_ops = NULL;
int32_target_ops = NULL;
int64_target_ops = NULL;
nativeint_target_ops = NULL;
ops_ptr = target_custom_ops;
while (ops_ptr != NULL) {
if (strcmp(ops_ptr->name, "_bigarray") == 0)
bigarray_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_i") == 0)
int32_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_j") == 0)
int64_target_ops = ops_ptr->ops;
else if (strcmp(ops_ptr->name, "_n") == 0)
nativeint_target_ops = ops_ptr->ops;
ops_ptr = ops_ptr->next;
};
/* First pass: Iterate over the addresses found in q. Ignore
addresses already seen in the past (which are in t). For
new addresses, make a copy, and add these copies to t.
*/
/* fprintf(stderr, "first pass, orig_addr=%lx simulation=%d addr_delta=%lx\n",
(unsigned long) orig_addr, simulation, addr_delta);
*/
code = netsys_queue_take(q, &work_addr);
while (code != (-3)) {
if (code != 0) return code;
/* fprintf(stderr, "work_addr=%lx\n", (unsigned long) work_addr); */
code = netsys_htab_lookup(t, work_addr, ©_addr);
if (code != 0) return code;
if (copy_addr == NULL) {
/* The address is unknown, so copy the value */
/* Body of first pass */
work = (value) work_addr;
work_tag = Tag_val(work);
work_header = Hp_val(work);
if (work_tag < No_scan_tag) {
/* It is a scanned value (with subvalues) */
switch(work_tag) {
case Object_tag:
case Closure_tag:
case Lazy_tag:
case Forward_tag:
return (-2); /* unsupported */
}
work_words = Wosize_hp(work_header);
if (work_words == 0) {
if (!enable_atoms) return (-2);
if (enable_atoms == 1) goto next;
};
/* Do the copy. */
work_bytes = Bhsize_hp(work_header);
copy_header = dest_cur;
dest_cur += work_bytes;
if (dest_cur > dest_end && !simulation) return (-4);
if (simulation)
copy_addr = work_addr;
else {
memcpy(copy_header, work_header, work_bytes);
copy = Val_hp(copy_header);
copy_addr = (void *) copy;
Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
}
/* Add the association (work_addr -> copy_addr) to t: */
code = netsys_htab_add(t, work_addr, copy_addr);
if (code < 0) return code;
/* Add the sub values of work_addr to q: */
for (i=0; i < work_words; ++i) {
value field = Field(work, i);
if (Is_block (field)) {
code = netsys_queue_add(q, (void *) field);
if (code != 0) return code;
}
}
}
else {
/* It an opaque value */
int do_copy = 0;
int do_bigarray = 0;
void *target_ops = NULL;
char caml_id = ' '; /* only b, i, j, n */
/* Check for bigarrays and other custom blocks */
switch (work_tag) {
case Abstract_tag:
return(-2);
case String_tag:
do_copy = 1; break;
case Double_tag:
do_copy = 1; break;
case Double_array_tag:
do_copy = 1; break;
case Custom_tag:
{
struct custom_operations *custom_ops;
char *id;
custom_ops = Custom_ops_val(work);
id = custom_ops->identifier;
if (id[0] == '_') {
switch (id[1]) {
case 'b':
if (!enable_bigarrays) return (-2);
if (strcmp(id, "_bigarray") == 0) {
caml_id = 'b';
break;
}
case 'i': /* int32 */
case 'j': /* int64 */
case 'n': /* nativeint */
if (!enable_customs) return (-2);
if (id[2] == 0) {
caml_id = id[1];
break;
}
default:
return (-2);
}
}
else
return (-2);
}
}; /* switch */
switch (caml_id) { /* look closer at some cases */
case 'b': {
target_ops = bigarray_target_ops;
do_copy = 1;
do_bigarray = 1;
break;
}
case 'i':
target_ops = int32_target_ops; do_copy = 1; break;
case 'j':
target_ops = int64_target_ops; do_copy = 1; break;
case 'n':
target_ops = nativeint_target_ops; do_copy = 1; break;
};
if (do_copy) {
/* Copy the value */
work_bytes = Bhsize_hp(work_header);
copy_header = dest_cur;
dest_cur += work_bytes;
if (simulation)
copy_addr = work_addr;
else {
if (dest_cur > dest_end) return (-4);
memcpy(copy_header, work_header, work_bytes);
copy = Val_hp(copy_header);
copy_addr = (void *) copy;
Hd_val(copy) = Whitehd_hd(Hd_val(copy)) | color;
if (target_ops != NULL)
Custom_ops_val(copy) = target_ops;
}
code = netsys_htab_add(t, work_addr, copy_addr);
if (code < 0) return code;
}
if (do_bigarray) {
/* postprocessing for copying bigarrays */
struct caml_ba_array *b_work, *b_copy;
void * data_copy;
char * data_header;
header_t data_header1;
size_t size = 1;
size_t size_aligned;
size_t size_words;
b_work = Bigarray_val(work);
b_copy = Bigarray_val(copy);
for (i = 0; i < b_work->num_dims; i++) {
size = size * b_work->dim[i];
};
size =
size *
caml_ba_element_size[b_work->flags & BIGARRAY_KIND_MASK];
size_aligned = size;
if (size%sizeof(void *) != 0)
size_aligned += sizeof(void *) - (size%sizeof(void *));
size_words = Wsize_bsize(size_aligned);
/* If we put the copy of the bigarray into our own
dest buffer, also generate an abstract header,
so it can be skipped when iterating over it.
We use here a special representation, so we can
encode any length in this header (with a normal
Ocaml header we are limited by Max_wosize, e.g.
16M on 32 bit systems). The special representation
is an Abstract_tag with zero length, followed
by the real length (in words)
*/
if (enable_bigarrays == 2) {
data_header = dest_cur;
dest_cur += 2*sizeof(void *);
data_copy = dest_cur;
dest_cur += size_aligned;
} else if (!simulation) {
data_header = NULL;
data_copy = stat_alloc(size_aligned);
};
if (!simulation) {
if (dest_cur > dest_end) return (-4);
/* Initialize header: */
if (data_header != NULL) {
data_header1 = Abstract_tag;
memcpy(data_header,
(char *) &data_header1,
sizeof(header_t));
memcpy(data_header + sizeof(header_t),
(size_t *) &size_words,
sizeof(size_t));
};
/* Copy bigarray: */
memcpy(data_copy, b_work->data, size);
b_copy->data = data_copy;
b_copy->proxy = NULL;
/* If the copy is in our own buffer, it is
now externally managed.
*/
b_copy->flags =
(b_copy->flags & ~CAML_BA_MANAGED_MASK) |
(enable_bigarrays == 2 ?
CAML_BA_EXTERNAL :
CAML_BA_MANAGED);
}
}
} /* if (work_tag < No_scan_tag) */
} /* if (copy_addr == NULL) */
/* Switch to next address in q: */
next:
code = netsys_queue_take(q, &work_addr);
} /* while */
/* Second pass. The copied blocks still have fields pointing to the
original blocks. We fix that now by iterating once over the copied
memory block.
*/
if (!simulation) {
/* fprintf(stderr, "second pass\n"); */
dest_ptr = dest;
while (dest_ptr < dest_cur) {
copy_header1 = *((header_t *) dest_ptr);
copy_tag = Tag_hd(copy_header1);
copy_words = Wosize_hd(copy_header1);
copy = (value) (dest_ptr + sizeof(void *));
if (copy_tag < No_scan_tag) {
for (i=0; i < copy_words; ++i) {
value field = Field(copy, i);
if (Is_block (field)) {
/* It is a pointer. Try to fix it up. */
code = netsys_htab_lookup(t, (void *) field,
&fixup_addr);
if (code != 0) return code;
if (fixup_addr != NULL)
Field(copy,i) =
(value) (((char *) fixup_addr) + addr_delta);
}
}
}
else if (copy_tag == Abstract_tag && copy_words == 0) {
/* our special representation for skipping data regions */
copy_words = ((size_t *) dest_ptr)[1] + 1;
};
dest_ptr += (copy_words + 1) * sizeof(void *);
}
}
/* hey, fine. Return result */
*start_offset = sizeof(void *);
*bytelen = dest_cur - dest;
/* fprintf(stderr, "return regularly\n");*/
return 0;
}
value netsys_init_value(value memv,
value offv,
value orig,
value flags,
value targetaddrv,
value target_custom_ops
)
{
int code;
value r;
intnat start_offset, bytelen;
int cflags;
void *targetaddr;
char *mem_data;
char *mem_end;
intnat off;
struct named_custom_ops *ops, *old_ops, *next_ops;
code = prep_stat_tab();
if (code != 0) goto exit;
code = prep_stat_queue();
if (code != 0) goto exit;
off = Long_val(offv);
if (off % sizeof(void *) != 0) { code=(-2); goto exit; }
cflags = caml_convert_flag_list(flags, init_value_flags);
targetaddr = (void *) (Nativeint_val(targetaddrv) + off);
ops = NULL;
while (Is_block(target_custom_ops)) {
value pair;
old_ops = ops;
pair = Field(target_custom_ops,0);
ops = (struct named_custom_ops*)
stat_alloc(sizeof(struct named_custom_ops));
ops->name = stat_alloc(caml_string_length(Field(pair,0))+1);
strcmp(ops->name, String_val(Field(pair,0)));
ops->ops = (void *) Nativeint_val(Field(pair,1));
ops->next = old_ops;
target_custom_ops = Field(target_custom_ops,1);
};
mem_data = ((char *) Bigarray_val(memv)->data) + off;
mem_end = mem_data + Bigarray_val(memv)->dim[0];
/* note: the color of the new values does not matter because bigarrays
are ignored by the GC. So we pass 0 (white).
*/
code = netsys_init_value_1(stat_tab, stat_queue, mem_data, mem_end, orig,
(cflags & 1) ? 2 : 0,
(cflags & 2) ? 1 : 0,
(cflags & 4) ? 2 : 0,
cflags & 8,
targetaddr, ops, 0,
&start_offset, &bytelen);
if (code != 0) goto exit;
unprep_stat_tab();
unprep_stat_queue();
while (ops != NULL) {
next_ops = ops->next;
stat_free(ops->name);
stat_free(ops);
ops = next_ops;
};
r = caml_alloc_small(2,0);
Field(r,0) = Val_long(start_offset + off);
Field(r,1) = Val_long(bytelen);
return r;
exit:
unprep_stat_queue();
unprep_stat_tab();
switch(code) {
case (-1):
unix_error(errno, "netsys_init_value", Nothing);
case (-2):
failwith("Netsys_mem.init_value: Library error");
case (-4):
caml_raise_constant(*caml_named_value("Netsys_mem.Out_of_space"));
default:
failwith("Netsys_mem.init_value: Unknown error");
}
}