value fortran_printtab(value ba)
{
int dimx = Bigarray_val(ba)->dim[0];
int dimy = Bigarray_val(ba)->dim[1];
printtab_(Data_bigarray_val(ba), &dimx, &dimy);
return Val_unit;
}
/* T.F. additions - same style. We use these to distribute mesh info */
value caml_mpi_broadcast_bigarray_float(value data, value root, value comm)
{
mlsize_t len = Bigarray_val(data)->dim[0];
double *d = Data_bigarray_val(data);
MPI_Bcast(d, len, MPI_DOUBLE, Int_val(root), Comm_val(comm));
return Val_unit;
}
CAMLprim value netsys_init_string(value memv, value offv, value lenv)
{
struct caml_bigarray *b = Bigarray_val(memv);
intnat off = Long_val(offv);
intnat len = Long_val(lenv);
value *m;
char *m_b;
mlsize_t wosize;
mlsize_t offset_index;
#ifdef ARCH_SIXTYFOUR
if (off % 8 != 0)
invalid_argument("Netsys_mem.init_string");
#else
if (off % 4 != 0)
invalid_argument("Netsys_mem.init_string");
#endif
m = (value *) (((char *) b->data) + off);
m_b = (char *) m;
wosize = (len + sizeof (value)) / sizeof (value); /* >= 1 */
m[0] = /* Make_header (wosize, String_tag, Caml_white) */
(value) (((header_t) wosize << 10) + String_tag);
m[wosize] = 0;
offset_index = Bsize_wsize (wosize) - 1;
m_b[offset_index + sizeof(value)] = offset_index - len;
return Val_unit;
}
value unix_util_write(value fd,value buf)
{
value vres=alloc(1,1); /* Ok result */
int res;
enter_blocking_section();
res = write(Int_val(fd), /* TODO: unsafe coercion */
Bigarray_val(buf)->data,Bigarray_val(buf)->dim[0]);
leave_blocking_section();
if (res >=0) Field(vres,0)=Val_int(res);
else
{
Tag_val(vres)=0; /* Bad result */
Field(vres,0)=Val_int(c2ml_unix_error(res)); /* TODO: EUNKNOWN x is a block */
}
return vres;
}
CAMLprim value netsys_zero_pages(value memv, value offsv, value lenv)
{
#if defined(HAVE_MMAP) && defined(HAVE_SYSCONF) && defined(MAP_ANON) && defined (MAP_FIXED)
struct caml_bigarray *mem = Bigarray_val(memv);
long offs = Long_val(offsv);
long len = Long_val(lenv);
long pgsize = sysconf(_SC_PAGESIZE);
char *data = ((char*) mem->data) + offs;
void *data2;
if (((uintnat) data) % pgsize == 0 && len % pgsize == 0) {
if (len > 0) {
data2 = mmap(data, len, PROT_READ|PROT_WRITE,
MAP_PRIVATE | MAP_ANON | MAP_FIXED,
(-1), 0);
if (data2 == (void *) -1) uerror("mmap", Nothing);
if (((void *) data) != data2)
failwith("Netsys_mem.zero_pages assertion failed");
}
}
else
invalid_argument("Netsys_mem.zero_pages only for whole pages");
return Val_unit;
#else
invalid_argument("Netsys_mem.zero_pages not available");
#endif
}
value caml_mpi_broadcast_bigarray_nativeint(value data, value root, value comm)
{
mlsize_t len = Bigarray_val(data)->dim[0];
double *d = Data_bigarray_val(data);
MPI_Bcast(d, len, MPI_LONG, Int_val(root), Comm_val(comm));
/* According to the docs, MPI_LONG is right, even on LC64 machines. */
return Val_unit;
}
CAMLprim value string_to_binary_array (value dst_arr, value dst_idx, value src_str)
{
CAMLparam3 (dst_arr, dst_idx, src_str);
int len = string_length (src_str), idx = Long_val(dst_idx);
if (idx + len > Bigarray_val(dst_arr)->dim[0]) invalid_argument ("Binarray.write");
memcpy ((char *) Data_bigarray_val(dst_arr) + idx, String_val(src_str), len);
CAMLreturn (Val_unit);
}
CAMLprim value ml_blit_buffer_to_string
(value a, value i, value s, value j, value l)
{
char *src = Array_data(Bigarray_val(a), i);
char *dest = String_val(s) + Long_val(j);
memcpy(dest, src, Long_val(l));
return Val_unit;
}
CAMLprim value cstring_to_binary_array (value dst_arr, value dst_idx, value dst_len, value src_str)
{
CAMLparam4 (dst_arr, dst_idx, dst_len, src_str);
int len = string_length (src_str), idx = Long_val(dst_idx), dlen = Long_val(dst_len);
if (idx + dlen > Bigarray_val(dst_arr)->dim[0] || len > dlen) invalid_argument ("Binarray.write_sz");
memcpy ((char *) Data_bigarray_val(dst_arr) + idx, String_val(src_str), len);
memset ((char *) Data_bigarray_val(dst_arr) + idx + len, 0, dlen - len);
CAMLreturn (Val_unit);
}
CAMLprim value
ml_gsl_wavelet_transform_bigarray (value w, value dir, value b, value ws)
{
struct caml_bigarray *bigarr = Bigarray_val(b);
double *data = bigarr->data;
size_t n = bigarr->dim[0];
gsl_wavelet_transform (Wavelet_val (w), data, 1, n,
gsl_direction_val (dir), WS_val (ws));
return Val_unit;
}
CAMLprim value win_write
(value fd, value buf, value ofs, value len, value id) {
CAMLparam4(fd, buf, ofs, len);
struct caml_bigarray *buf_arr = Bigarray_val(buf);
if (Field(fd, 1) == Val_long(0))
overlapped_action (WRITE_OVERLAPPED, Long_val(id), Handle(fd),
Array_data (buf_arr, ofs), Long_val(len));
else
thread_io (WRITE, Long_val(id), Field(fd, 1), Handle(fd),
Array_data (buf_arr, ofs), Long_val(len));
CAMLreturn (Val_unit);
}
value ml_cv_convert_bigarray( value converter, value src, value dest ) {
CAMLparam3( converter, src, dest );
int n;
n = Bigarray_val( dest )->dim[0];
if ( n > Bigarray_val( src )->dim[0] ) {
caml_raise_with_arg( *caml_named_value( "ut status exception" ), Val_int( UT_BAD_ARG ) );
}
if ( (Bigarray_val( src )->flags & BIGARRAY_KIND_MASK) == BIGARRAY_FLOAT32 ) {
cv_convert_floats( UD_cv_converter_val( converter ), Data_bigarray_val( src ), n, Data_bigarray_val( dest ) );
}
else if ( (Bigarray_val( src )->flags & BIGARRAY_KIND_MASK) == BIGARRAY_FLOAT64 ) {
cv_convert_doubles( UD_cv_converter_val( converter ), Data_bigarray_val( src ), n, Data_bigarray_val( dest ) );
}
else {
caml_raise_with_arg( *caml_named_value( "ut status exception" ), Val_int( UT_BAD_ARG ) );
}
CAMLreturn( Val_unit );
}
CAMLprim value netsys_value_area_remove(value memv)
{
#ifdef FANCY_PAGE_TABLES
struct caml_bigarray *b = Bigarray_val(memv);
int code;
code = caml_page_table_remove(In_static_data,
b->data,
b->data + b->dim[0]);
/* Silently ignore errors... */
return Val_unit;
#else
invalid_argument("Netsys_mem.value_area");
#endif
}
CAMLprim value netsys_value_area_add(value memv)
{
#ifdef FANCY_PAGE_TABLES
struct caml_bigarray *b = Bigarray_val(memv);
int code;
code = caml_page_table_add(In_static_data,
b->data,
b->data + b->dim[0]);
if (code != 0)
failwith("Netsys_mem.value_area: error");
return Val_unit;
#else
invalid_argument("Netsys_mem.value_area");
#endif
}
CAMLprim value netsys_blit_string_to_memory(value sv,
value soffv,
value memv,
value memoffv,
value lenv)
{
struct caml_bigarray *mem = Bigarray_val(memv);
char * s = String_val(sv);
long memoff = Long_val(memoffv);
long soff = Long_val(soffv);
long len = Long_val(lenv);
memmove(((char*) mem->data) + memoff, s + soff, len);
return Val_unit;
}
static void thread_io
(long action, long id, value threads, HANDLE h, char * buf, long len) {
struct caml_bigarray *buf_arr = Bigarray_val(buf);
ioInfo * info = GlobalAlloc(GPTR, sizeof(ioInfo));
if (info == NULL) {
errno = ENOMEM;
uerror(action_name[action], Nothing);
}
info->action = action;
info->id = id;
info->fd = h;
info->buffer = buf;
info->len = len;
h = get_helper_thread(threads, action);
QueueUserAPC(perform_io_on_thread, h, (ULONG_PTR) info);
}
CAMLprim value
ml_sqlite3_bind_blob_big (value s, value idx, value v)
{
sqlite3_stmt *stmt = Sqlite3_stmt_val (s);
int i = Int_val (idx);
int status;
struct caml_bigarray *ba;
ba = Bigarray_val (v);
status = sqlite3_bind_blob (stmt, i,
ba->data, ba->dim[0],
ml_sqlite3_release_big);
if (status != SQLITE_OK)
ml_sqlite3_raise_exn (status, "sqlite3_bind failed", TRUE);
ml_sqlite3_register_big (v);
return Val_unit;
}
CAMLprim value netsys_memory_unmap_file(value memv)
{
struct caml_bigarray *b = Bigarray_val(memv);
if ((b->flags & BIGARRAY_MANAGED_MASK) == BIGARRAY_MAPPED_FILE) {
if (b->proxy == NULL) {
ba_unmap_file(b->data, b->dim[0]);
b->data = NULL;
b->flags =
(b->flags & ~BIGARRAY_MANAGED_MASK) | BIGARRAY_EXTERNAL;
}
else if (b->proxy->refcount == 1) {
ba_unmap_file(b->proxy->data, b->dim[0]);
b->proxy->data = NULL;
b->data = NULL;
b->flags =
(b->flags & ~BIGARRAY_MANAGED_MASK) | BIGARRAY_EXTERNAL;
}
}
return Val_unit;
}
CAMLprim value digest_array (value v_iarr)
{
CAMLparam1(v_iarr);
CAMLlocal1(result);
MD5Context context;
int len = Bigarray_val(v_iarr)->dim[0];
unsigned char *buf = Data_bigarray_val(v_iarr);
MD5Init (&context);
while (len > 0) {
int block = (len > 8192) ? 8192 : len;
MD5Update (&context, buf, block);
buf += block;
len -= block;
}
result = alloc_string (16);
MD5Final (&Byte_u(result, 0), &context);
CAMLreturn(result);
}
CAMLprim value netsys_mem_write(value fdv, value memv, value offv, value lenv)
{
intnat numbytes;
intnat ret;
char *data;
#ifdef _WIN32
DWORD n;
DWORD err = 0;
#endif
numbytes = Long_val(lenv);
data = ((char *) (Bigarray_val(memv)->data)) + Long_val(offv);
#ifdef _WIN32
if (Descr_kind_val(fdv) == KIND_SOCKET) {
SOCKET h = Socket_val(fdv);
enter_blocking_section();
ret = send(h, data, numbytes, 0);
if (ret == SOCKET_ERROR) err = WSAGetLastError();
leave_blocking_section();
ret = n;
} else {
HANDLE h = Handle_val(fdv);
enter_blocking_section();
if (! WriteFile(h, data, numbytes, &n, NULL)) err = GetLastError();
leave_blocking_section();
ret = n;
}
if (err) {
win32_maperr(err);
ret = -1;
}
#else
enter_blocking_section();
ret = write(Int_val(fdv), data, (int) numbytes);
leave_blocking_section();
#endif
if (ret == -1) uerror("mem_write", Nothing);
return Val_long(ret);
}
CAMLprim value stub_gntshr_munmap_batched(value xgh, value share) {
CAMLparam2(xgh, share);
CAMLlocal1(ml_map);
#ifdef HAVE_GNTSHR
ml_map = Field(share, 1);
int size = Bigarray_val(ml_map)->dim[0];
int pages = size >> XC_PAGE_SHIFT;
#ifdef linux
/* Bug in xen-4.4 libxc xc_linux_osdep implementation, work-around
by using the kernel interface directly. */
int result = munmap(Data_bigarray_val(ml_map), size);
#else
int result = xc_gntshr_munmap(_G(xgh), Data_bigarray_val(ml_map), pages);
#endif
if(result != 0)
failwith_xc(_G(xgh));
#else
gntshr_missing();
#endif
CAMLreturn(Val_unit);
}
CAMLprim value netsys_mem_send(value fdv, value memv, value offv, value lenv,
value flagsv)
{
intnat numbytes;
intnat ret;
char *data;
int flags;
#ifdef _WIN32
DWORD err = 0;
SOCKET s;
#else
int s;
#endif
numbytes = Long_val(lenv);
data = ((char *) (Bigarray_val(memv)->data)) + Long_val(offv);
flags = convert_flag_list(flagsv, msg_flag_table);
#ifdef _WIN32
s = Socket_val(fdv);
#else
s = Int_val(fdv);
#endif
enter_blocking_section();
ret = send(s, data, (int) numbytes, flags);
#ifdef _WIN32
if (ret == -1) err = WSAGetLastError();
leave_blocking_section();
if (ret == -1) win32_maperr(err);
#else
leave_blocking_section();
#endif
if (ret == -1) uerror("mem_send", Nothing);
return Val_long(ret);
}
CAMLprim value win_readdirtorychanges
(value fd_val, value buf_val, value recursive, value flags, value id_val) {
CAMLparam5(fd_val, buf_val, recursive, flags, id_val);
struct caml_bigarray *buf_arr = Bigarray_val(buf_val);
long id = Long_val(id_val);
HANDLE fd = Handle_val(fd_val);
char * buf = Array_data (buf_arr, 0);
long len = buf_arr->dim[0];
long action = READDIRECTORYCHANGES;
BOOL res;
long err;
int notify_filter = convert_flag_list(flags, notify_filter_flags);
completionData * d = GlobalAlloc(GPTR, sizeof(completionData));
if (d == NULL) {
errno = ENOMEM;
uerror(action_name[action], Nothing);
}
d->id = id;
d->action = action;
D(printf("Starting %s: id %ld, len %ld\n", action_name[action], id, len));
res = ReadDirectoryChangesW (fd, buf, len, Bool_val(recursive),
notify_filter, NULL, &(d->overlapped),
overlapped_completion);
if (!res) {
err = GetLastError ();
if (err != ERROR_IO_PENDING) {
win32_maperr (err);
D(printf("Action %s failed: id %ld -> err %d (errCode %ld)\n",
action_name[action], id, errno, err));
uerror("ReadDirectoryChangesW", Nothing);
}
}
CAMLreturn (Val_unit);
}
CAMLprim value win_parse_directory_changes (value buf_val) {
CAMLparam1(buf_val);
CAMLlocal4(lst, tmp, elt, filename);
struct caml_bigarray *buf_arr = Bigarray_val(buf_val);
char * pos = Array_data (buf_arr, 0);
FILE_NOTIFY_INFORMATION * entry;
lst = Val_long(0);
while (1) {
entry = (FILE_NOTIFY_INFORMATION *)pos;
elt = caml_alloc_tuple(2);
filename = caml_alloc_string(entry->FileNameLength);
memmove(String_val(filename), entry->FileName, entry->FileNameLength);
Store_field (elt, 0, filename);
Store_field (elt, 1, Val_long(entry->Action - 1));
tmp = caml_alloc_tuple(2);
Store_field (tmp, 0, elt);
Store_field (tmp, 1, lst);
lst = tmp;
if (entry->NextEntryOffset == 0) break;
pos += entry->NextEntryOffset;
}
CAMLreturn(lst);
}
CAMLprim value netsys_init_header(value memv, value offv, value tagv,
value sizev)
{
struct caml_bigarray *b = Bigarray_val(memv);
intnat off = Long_val(offv);
intnat size = Long_val(sizev);
int tag = Int_val(tagv);
value *m;
#ifdef ARCH_SIXTYFOUR
if (off % 8 != 0)
invalid_argument("Netsys_mem.init_header");
#else
if (off % 4 != 0)
invalid_argument("Netsys_mem.init_header");
#endif
m = (value *) (((char *) b->data) + off);
m[0] = /* Make_header (wosize, tag, Caml_white) */
(value) (((header_t) size << 10) + tag);
return Val_unit;
}
value
sankoff_CAML_create_eltarr (value is_identity, value taxon_code, value code, value number_of_states, value ecode_bigarr, value states_bigarr, value tcm_bigarr) {
CAMLparam5(is_identity,taxon_code,code,number_of_states,ecode_bigarr);
CAMLxparam2(states_bigarr,tcm_bigarr);
CAMLlocal1(res);
int num_states;
num_states = Int_val(number_of_states);
int tcode = Int_val(taxon_code);
int iside = Int_val(is_identity);
int mycode = Int_val(code);
int * cost_mat; int dimcm1, dimcm2;
int * states_arrarr; int dims1, dims2;
int * ecode_arr; int dim;
ecode_arr = (int*) Data_bigarray_val(ecode_bigarr);
dim = Bigarray_val(ecode_bigarr)->dim[0];//number of elts
states_arrarr = (int*) Data_bigarray_val(states_bigarr);
dims1 = Bigarray_val(states_bigarr)->dim[0]; //number of elts
dims2 = Bigarray_val(states_bigarr)->dim[1]; //number of states in each elt
if (dim!=dims1) failwith ("sankoff.c, size of ecode array != number of charactors");
if (dims2!= num_states) failwith ("sankoff.c, size of states array != number of states");
cost_mat = (int*) Data_bigarray_val(tcm_bigarr);
dimcm1 = Bigarray_val(tcm_bigarr)->dim[0];//number of states
dimcm2 = Bigarray_val(tcm_bigarr)->dim[1];//number of states
if ((dimcm1!=dimcm2)||(dimcm1!=dims2))
failwith ("sankoff.c, wrong size of costmat between states");
eltarr_p neweltarr;
//alloc struct elt_arr
neweltarr = (eltarr_p)calloc(1,sizeof(struct elt_arr));
neweltarr->code = mycode;
neweltarr->taxon_code = tcode;
neweltarr->left_taxon_code = tcode;
neweltarr->right_taxon_code = tcode;
neweltarr->sum_cost = 0;
neweltarr->num_states = dimcm1;
neweltarr->num_elts = dim;
neweltarr->is_identity = iside;
//alloc its pointers
neweltarr->tcm = (int*)calloc(dimcm1*dimcm2,sizeof(int));
memcpy(neweltarr->tcm,cost_mat,sizeof(int) * dimcm1 * dimcm2);
neweltarr->elts = (elt_p)calloc(dim,sizeof(struct elt));
int i; int j;
int * states_arr;
elt_p newelt;
for (i=0;i<dim;i++)
{
newelt = &((neweltarr->elts)[i]);
assert(newelt!=NULL);
newelt->ecode = ecode_arr[i];
newelt->num_states = num_states;
newelt->states = (int*)calloc( num_states, sizeof(int) );
newelt->leftstates = (int*)calloc( num_states, sizeof(int) );
newelt->rightstates = (int*)calloc( num_states, sizeof(int) );
//for new median_3
if (median_3_su) {
newelt->left_costdiff_mat = (int*)calloc(num_states*num_states,sizeof(int));
newelt->right_costdiff_mat = (int*)calloc(num_states*num_states,sizeof(int));
}
states_arr = sankoff_move_to_line_i(states_arrarr,dims1,dims2,i);
//the infinity on ocaml side is diff from here, so we pass -1 instead
//memcpy(newelt->states,states_arr,sizeof(int)*num_states);
for (j=0;j<num_states;j++) {
(newelt->states)[j] = ( states_arr[j]==(-1) ) ? infinity : states_arr[j];
}
newelt->beta = (int*)calloc(num_states,sizeof(int));
newelt->e = (int*)calloc(num_states,sizeof(int));
newelt->m = (int*)calloc(num_states,sizeof(int));
sankoff_canonize(newelt,cost_mat);
}
res = caml_alloc_custom (&sankoff_custom_operations_eltarr,sizeof (eltarr_p), 1,alloc_custom_max);
Sankoff_return_eltarr(res) = neweltarr;
CAMLreturn(res);
}
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");
}
}
CAMLprim value netsys_memory_address(value memv)
{
struct caml_bigarray *mem = Bigarray_val(memv);
return caml_copy_nativeint((intnat) mem->data);
}
CAMLprim value netsys_as_value(value memv, value offv)
{
struct caml_bigarray *b = Bigarray_val(memv);
return (value) (b->data + Long_val(offv));
}
