value get_section_data_internal( bhp _p )
{
CAMLparam0();
CAMLlocal4( data, v, str, tupl );
bh* p = (bh*) _p;
struct bfd* abfd = p->bfdp;
asection *sect;
bfd_size_type datasize = 0;
data = Val_emptylist;
if ( p->is_from_file ) {
for ( sect = abfd->sections; sect != NULL; sect = sect->next ) {
datasize = bfd_get_section_size( sect );
str = caml_alloc_string( datasize );
bfd_get_section_contents( abfd, sect,
(bfd_byte*)String_val(str),
0, datasize );
tupl = caml_alloc_tuple( 3 );
Store_field( tupl, 0, str );
Store_field( tupl, 1, caml_copy_int64( sect->vma ) );
Store_field( tupl, 2, caml_copy_int64( sect->vma + datasize ) );
v = caml_alloc_small( 2, 0 );
Field( v, 0 ) = tupl;
Field( v, 1 ) = data;
data = v;
}
}
CAMLreturn( data );
}
bool check_mems_taint( memorylog_entry* memlog, unsigned int cnt )
{
CAMLparam0();
CAMLlocal4( addrs, ret, v, tupl );
static value *proc_check_mems_taint = NULL;
if ( !proc_check_mems_taint ) {
proc_check_mems_taint = caml_named_value( "check_mems_taint" );
}
addrs = Val_emptylist;
for ( unsigned int i = 0; i < cnt; i ++ ) {
tupl = caml_alloc_tuple( 2 );
Store_field( tupl, 0, caml_copy_nativeint( memlog[i].addr ) );
Store_field( tupl, 1, Val_int( memlog[i].size * 8 ) );
v = caml_alloc_small( 2, 0 );
Field( v, 0 ) = tupl;
Field( v, 1 ) = addrs;
addrs = v;
}
ret = caml_callback( *proc_check_mems_taint, addrs );
CAMLreturnT( bool, Bool_val( ret ) );
}
CAMLprim value
caml_tcpv4_accept(value v_fd)
{
CAMLparam1(v_fd);
CAMLlocal4(v_ret,v_err,v_ca,v_ip);
int r, fd=Int_val(v_fd);
struct sockaddr_in sa;
socklen_t len = sizeof sa;
r = accept(fd, (struct sockaddr *)&sa, &len);
if (r < 0) {
if (errno == EWOULDBLOCK || errno == EAGAIN)
Val_WouldBlock(v_ret);
else {
v_err = caml_copy_string(strerror(errno));
Val_Err(v_ret, v_err);
}
} else {
setnonblock(r);
v_ip = caml_copy_int32(ntohl(sa.sin_addr.s_addr));
v_ca = caml_alloc(3,0);
Store_field(v_ca, 0, Val_int(r));
Store_field(v_ca, 1, v_ip);
Store_field(v_ca, 2, Val_int(ntohs(sa.sin_port)));
Val_OK(v_ret, v_ca);
}
CAMLreturn(v_ret);
}
CAMLprim value spoc_cublasSetMatrix (value rows, value cols, value a, value lda, value b, value ldb, value dev){
CAMLparam5(rows, cols, a, lda, b);
CAMLxparam2(ldb, dev);
CAMLlocal4(dev_vec_array, dev_vec, gi, bigArray);
CUdeviceptr d_B;
void* h_A;
int type_size = sizeof(double);
int tag;
int id;
gi = Field(dev, 0);
id = Int_val(Field(gi, 7));
GET_VEC(b, d_B);
GET_HOST_VEC (a, h_A);
CUBLAS_GET_CONTEXT;
int custom = 0;
GET_TYPE_SIZE;
//printf("rows : %d, col: %d, type_size : %d, lda :%d, ldb : %d\n", Int_val(rows), Int_val(cols), type_size, Int_val (lda), Int_val(ldb));
//fflush(stdout);
CUBLAS_CHECK_CALL(cublasSetMatrix(Int_val(rows), Int_val(cols), type_size, h_A, Int_val(lda), (void*) d_B, Int_val(ldb)));
CUBLAS_RESTORE_CONTEXT;
CAMLreturn(Val_unit);
}
void ns_unix_error(int errcode, char *cmdname, value cmdarg)
{
CAMLparam0();
CAMLlocal4(res,name,err,arg);
name = err = arg = Val_unit;
Begin_roots3 (name, err, arg);
arg = cmdarg == Nothing ? copy_string("") : cmdarg;
name = copy_string(cmdname);
err =
cst_to_constr(errcode, ns_error_table, sizeof(ns_error_table)/sizeof(int));
if (unix_error_exn == NULL) {
unix_error_exn = caml_named_value("Ocamllib.Unix_error");
if (unix_error_exn == NULL)
invalid_argument("Exception Ocamllib.Unix_error not initialized, please link Ocamllib.cma");
}
res = alloc_small(4, 0);
Field(res, 0) = *unix_error_exn;
Field(res, 1) = err;
Field(res, 2) = name;
Field(res, 3) = arg;
End_roots();
mlraise(res);
CAMLreturn0;
}
CAMLprim value stub_gnttab_mapv_batched(
value xgh,
value array,
value writable)
{
CAMLparam3(xgh, array, writable);
CAMLlocal4(domid, reference, contents, pair);
int count = Wosize_val(array) / 2;
uint32_t domids[count];
uint32_t refs[count];
int i;
for (i = 0; i < count; i++) {
domids[i] = Int_val(Field(array, i * 2 + 0));
refs[i] = Int_val(Field(array, i * 2 + 1));
}
void *map =
xc_gnttab_map_grant_refs(_G(xgh),
count, domids, refs,
Bool_val(writable)?PROT_READ | PROT_WRITE : PROT_READ);
if(map==NULL) {
caml_failwith("Failed to map grant ref");
}
contents = caml_ba_alloc_dims(XC_GNTTAB_BIGARRAY, 1,
map, count << XC_PAGE_SHIFT);
pair = caml_alloc_tuple(2);
Store_field(pair, 0, contents); /* grant_handle */
Store_field(pair, 1, contents); /* Io_page.t */
CAMLreturn(pair);
}
value
camllistlist_from_itemlistlist (itemlist *args, int nargs) {
CAMLparam0();
CAMLlocal4(caml_items, caml_list, cur, last);
itemlist il;
int argct;
/* Convert C array of itemlists to Caml list of lists */
/* This is not pretty! */
if (nargs != 0) {
caml_list = cur = alloc(2,0);
last = Val_int(0);
for (argct = 0; argct < nargs; argct++) {
il = args[argct];
caml_items = camllist_from_itemlist(il);
if (last != Val_int(0)) Store_field(last, 1, cur);
Store_field(cur, 0, caml_items);
last = cur;
cur = alloc(2,0);
}
Store_field(last, 1, Val_int(0));
} else caml_list = Val_int(0);
CAMLreturn(caml_list);
}
value
string_list_of_strv (const gchar * const *v)
{
CAMLparam0();
CAMLlocal4(head, l, cell, s);
gsize i;
if (v == NULL)
CAMLreturn (Val_emptylist);
i = 0;
head = l = Val_emptylist;
while (v[i] != NULL)
{
s = copy_string (v[i]);
cell = alloc_small (2, Tag_cons);
Field (cell, 0) = s;
Field (cell, 1) = Val_emptylist;
if (l == Val_emptylist)
head = l = cell;
else
{
Field (l, 1) = cell;
l = cell;
}
i++;
}
CAMLreturn (head);
}
value
guestfs_int_mllib_parse_uri (value argv /* arg value, not an array! */)
{
CAMLparam1 (argv);
CAMLlocal4 (rv, sv, ssv, ov);
struct uri uri;
int r;
r = parse_uri (String_val (argv), &uri);
if (r == -1)
caml_invalid_argument ("URI.parse_uri");
/* Convert the struct into an OCaml tuple. */
rv = caml_alloc_tuple (5);
/* path : string */
sv = caml_copy_string (uri.path);
free (uri.path);
Store_field (rv, 0, sv);
/* protocol : string */
sv = caml_copy_string (uri.protocol);
free (uri.protocol);
Store_field (rv, 1, sv);
/* server : string array option */
if (uri.server) {
ssv = caml_copy_string_array ((const char **) uri.server);
guestfs_int_free_string_list (uri.server);
ov = caml_alloc (1, 0);
Store_field (ov, 0, ssv);
}
else
ov = Val_int (0);
Store_field (rv, 2, ov);
/* username : string option */
if (uri.username) {
sv = caml_copy_string (uri.username);
free (uri.username);
ov = caml_alloc (1, 0);
Store_field (ov, 0, sv);
}
else
ov = Val_int (0);
Store_field (rv, 3, ov);
/* password : string option */
if (uri.password) {
sv = caml_copy_string (uri.password);
free (uri.password);
ov = caml_alloc (1, 0);
Store_field (ov, 0, sv);
}
else
ov = Val_int (0);
Store_field (rv, 4, ov);
CAMLreturn (rv);
}
CAMLprim value caml_get_exception_backtrace(value unit)
{
CAMLparam0();
CAMLlocal4(arr, raw_slot, slot, res);
if (caml_debug_info == Val_emptylist) {
res = Val_int(0); /* None */
} else {
arr = caml_alloc(caml_backtrace_pos, 0);
if(caml_backtrace_buffer == NULL) {
Assert(caml_backtrace_pos == 0);
} else {
intnat i;
for(i = 0; i < caml_backtrace_pos; i++) {
raw_slot = Val_Codet(caml_backtrace_buffer[i]);
/* caml_convert_raw_backtrace_slot will not fail with
caml_failwith as we checked (events != NULL) already */
slot = caml_convert_raw_backtrace_slot(raw_slot);
caml_modify(&Field(arr, i), slot);
}
}
res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */
}
CAMLreturn(res);
}
CAMLprim value ocaml_gstreamer_message_parse_tag(value _msg)
{
CAMLparam1(_msg);
CAMLlocal4(v,s,t,ans);
GstMessage *msg = Message_val(_msg);
GstTagList *tags = NULL;
const GValue *val;
const gchar *tag;
int taglen;
int i, j, n;
caml_release_runtime_system();
gst_message_parse_tag(msg, &tags);
taglen = gst_tag_list_n_tags(tags);
caml_acquire_runtime_system();
ans = caml_alloc_tuple(taglen);
for(i = 0; i < taglen; i++)
{
t = caml_alloc_tuple(2);
// Tag name
tag = gst_tag_list_nth_tag_name(tags, i);
Store_field(t, 0, caml_copy_string(tag));
// Tag fields
n = gst_tag_list_get_tag_size(tags, tag);
v = caml_alloc_tuple(n);
for (j = 0; j < n; j++)
{
val = gst_tag_list_get_value_index(tags, tag, j);
if (G_VALUE_HOLDS_STRING(val)) {
s = caml_copy_string(g_value_get_string(val));
}
else if (GST_VALUE_HOLDS_DATE_TIME(val)) {
GstDateTime *dt = g_value_get_boxed(val);
gchar *dt_str = gst_date_time_to_iso8601_string(dt);
s = caml_copy_string(dt_str);
g_free(dt_str);
}
else {
//TODO: better typed handling of non-string values?
char *vc = g_strdup_value_contents(val);
s = caml_copy_string(vc);
free(vc);
}
Store_field(v, j, s);
}
Store_field(t, 1, v);
Store_field(ans, i, t);
}
gst_tag_list_unref(tags);
CAMLreturn(ans);
}
/* Added in 1.18 without a useful documentation. */
Evas_Object* ml_Elm_Gen_Item_Reusable_Content_Get_Cb(void* data, Evas_Object* obj, const char *part, Evas_Object *old)
{
CAMLparam0();
CAMLlocal4(v_obj, v_part, v_old, v);
value* v_class = data;
v_obj = copy_Evas_Object(obj);
v_part = copy_string(part);
v_old = copy_Evas_Object(old);
v = caml_callback3(Field(*v_class, 5), v_obj, v_part, v_old);
CAMLreturnT(Evas_Object*, Evas_Object_opt_val(v));
}
static int jacfn_withsens( /* IDASlsSparseJacFnB */
realtype t,
realtype cjB,
N_Vector yy,
N_Vector yp,
N_Vector *ys,
N_Vector *yps,
N_Vector yyB,
N_Vector ypB,
N_Vector resvalB,
SlsMat jacB,
void *user_data,
N_Vector tmp1B,
N_Vector tmp2B,
N_Vector tmp3B)
{
CAMLparam0();
CAMLlocalN(args, 4);
CAMLlocal4(session, bsensext, cb, smat);
WEAK_DEREF (session, *(value*)user_data);
bsensext = IDA_SENSEXT_FROM_ML(session);
cb = IDA_LS_CALLBACKS_FROM_ML(session);
cb = Field (cb, 0);
args[0] = sunml_idas_make_jac_arg(t, yy, yp, yyB, ypB, resvalB, cjB,
sunml_ida_make_triple_tmp (tmp1B, tmp2B, tmp3B));
int ns = Int_val(Field(bsensext, RECORD_IDAS_BWD_SESSION_NUMSENSITIVITIES));
args[1] = IDAS_BSENSARRAY1_FROM_EXT(bsensext);
sunml_idas_wrap_to_nvector_table(ns, args[1], ys);
args[2] = IDAS_BSENSARRAY2_FROM_EXT(bsensext);
sunml_idas_wrap_to_nvector_table(ns, args[2], yps);
smat = Field(cb, 1);
if (smat == Val_none) {
Store_some(smat, sunml_matrix_sparse_wrap(jacB));
Store_field(cb, 1, smat);
args[3] = Some_val(smat);
} else {
args[3] = Some_val(smat);
sunml_matrix_sparse_rewrap(args[3]);
}
/* NB: Don't trigger GC while processing this return value! */
value r = caml_callbackN_exn (Field(cb, 0), 4, args);
CAMLreturnT(int, CHECK_EXCEPTION(session, r, RECOVERABLE));
}
CAMLprim value spoc_cublasSnrm2 (value n, value x, value incx, value dev){
CAMLparam4(n,x,incx, dev);
CAMLlocal4(dev_vec_array, dev_vec, res, gi);
CUdeviceptr d_A;
int id;
float result;
GET_VEC(x, d_A);
CUBLAS_GET_CONTEXT;
result = cublasSnrm2(Int_val(n), (float*)d_A, Int_val(incx));
CUBLAS_CHECK_CALL(cublasGetError());
res = caml_copy_double((double)result);
CUDA_RESTORE_CONTEXT;
CAMLreturn((res));
}
static void push_vert(value root, double x, double y, double z)
{
CAMLparam1(root);
CAMLlocal4(vert, xx, yy, zz);
value cons;
xx = copy_double(x); yy = copy_double(y); zz = copy_double(z);
vert = alloc_tuple(3);
Field(vert,0) = xx;
Field(vert,1) = yy;
Field(vert,2) = zz;
cons = alloc_tuple(2);
Field(cons, 0) = vert;
Field(cons, 1) = Field(root,0);
modify(&Field(root,0), cons);
CAMLreturn0;
}
struct string_list *
verify_tal_file (char *typerep, int typereplen,
char *tofile, int tofilelen,
char *codefile, int codefilelen)
{
CAMLparam0();
CAMLlocal4(Caml_typerep,Caml_tofile,Caml_codefile,answer);
static value *verify_tal_file_closure = NULL;
struct string_list *retval = NULL;
Caml_typerep = alloc_string(typereplen);
Caml_tofile = alloc_string(tofilelen);
Caml_codefile = alloc_string(codefilelen);
memcpy(String_val(Caml_typerep),typerep,typereplen);
memcpy(String_val(Caml_tofile),tofile,tofilelen);
memcpy(String_val(Caml_codefile),codefile,codefilelen);
if (verify_tal_file_closure == NULL)
verify_tal_file_closure = caml_named_value ("verify_tal_file");
answer = callback3(*verify_tal_file_closure,
Caml_typerep, Caml_tofile, Caml_codefile);
/* process the results -- should be a string list option */
/* convert it to a C struct */
if (Is_block(answer)) {
value list = Field(answer, 0);
struct string_list tmp;
struct string_list *ptmp = &tmp;
while (Is_block(list)) {
ptmp->next = GC_malloc(sizeof(struct string_list));
ptmp = ptmp->next;
if (retval == NULL) {
retval = ptmp;
}
ptmp->str = CONVERT_SYM((char *)(Field(list, 0)));
list = Field(list,1);
}
}
/* else None */
CAMLreturn(retval);
}
CAMLprim value spoc_cublasSrot (value n, value x, value incx, value y, value incy, value sc, value ss, value dev){
CAMLparam5(n,x,incx, y, incy);
CAMLxparam3(sc, ss, dev);
CAMLlocal4(dev_vec_array, dev_vec, res, gi);
int id;
CUdeviceptr d_A;
CUdeviceptr d_B;
float result;
GET_VEC(x, d_A);
GET_VEC(y, d_B);
CUBLAS_GET_CONTEXT;
cublasSrot(Int_val(n), (float*)d_A, Int_val(incx), (float*)d_B, Int_val(incy), (float)(Double_val(sc)), (float)(Double_val(ss)));
CUBLAS_CHECK_CALL(cublasGetError());
CUDA_RESTORE_CONTEXT;
CAMLreturn(Val_unit);
}
paranode mk_lambda(char **args, int num_args, paranode body,
source_info_t *src_info) {
//printf("C: mk_lambda\n");
CAMLparam0();
CAMLlocal4(lam, args_list, node, val_body);
//TODO: Unbreak this by creating a formal_args object
val_body = get_value_and_remove_root(body);
args_list = build_str_list(args, num_args);
// Build the lambda expression
lam = caml_alloc(2, Exp_Lambda);
Store_field(lam, 0, args_list);
Store_field(lam, 1, val_body);
// Build the node and return
CAMLreturnT(paranode, mk_node(lam, src_info));
}
CAMLprim value stub_xc_gntshr_share_pages(value xgh, value domid, value count, value writeable) {
CAMLparam4(xgh, domid, count, writeable);
CAMLlocal4(result, ml_refs, ml_refs_cons, ml_map);
#ifdef HAVE_GNTSHR
void *map;
uint32_t *refs;
uint32_t c_domid;
int c_count;
int i;
c_count = Int_val(count);
c_domid = Int32_val(domid);
result = caml_alloc(2, 0);
refs = (uint32_t *) malloc(c_count * sizeof(uint32_t));
map = xc_gntshr_share_pages(_G(xgh), c_domid, c_count, refs, Bool_val(writeable));
if(NULL == map) {
free(refs);
failwith_xc(_G(xgh));
}
// Construct the list of grant references.
ml_refs = Val_emptylist;
for(i = c_count - 1; i >= 0; i--) {
ml_refs_cons = caml_alloc(2, 0);
Store_field(ml_refs_cons, 0, caml_copy_int32(refs[i]));
Store_field(ml_refs_cons, 1, ml_refs);
ml_refs = ml_refs_cons;
}
ml_map = caml_ba_alloc_dims(XC_GNTTAB_BIGARRAY, 1,
map, c_count << XC_PAGE_SHIFT);
Store_field(result, 0, ml_refs);
Store_field(result, 1, ml_map);
free(refs);
#else
gntshr_missing();
#endif
CAMLreturn(result);
}
CAMLprim value spoc_cublasSrotm (value n, value x, value incx, value y, value incy, value sparam, value dev){
CAMLparam5(n,x,incx, y, incy);
CAMLxparam2(sparam, dev);
CAMLlocal4(dev_vec_array, dev_vec, res, gi);
CUdeviceptr d_A;
CUdeviceptr d_B;
CUdeviceptr d_C;
float result;
int id;
GET_VEC(x, d_A);
GET_VEC(y, d_B);
GET_VEC(sparam, d_C);
CUBLAS_GET_CONTEXT;
cublasSrotm(Int_val(n), (float*)d_A, Int_val(incx), (float*)d_B, Int_val(incy), (float*)sparam);
CUBLAS_CHECK_CALL(cublasGetError());
CUBLAS_RESTORE_CONTEXT;
CAMLreturn(Val_unit);
}
paranode mk_if(paranode cond_node, paranode true_node, paranode false_node,
source_info_t *src_info) {
//printf("C: ast_stubs.mk_if\n");
CAMLparam0();
CAMLlocal4(val_cond, val_true, val_false, if_node);
if_node = caml_alloc(3, Exp_If);
val_cond = get_value_and_remove_root(cond_node);
Store_field(if_node, 0, val_cond);
val_true = get_value_and_remove_root(true_node);
Store_field(if_node, 1, val_true);
val_false = get_value_and_remove_root(false_node);
Store_field(if_node, 2, val_false);
CAMLreturnT(paranode, mk_node(if_node, src_info));
}
static void
event_callback_wrapper_locked (guestfs_h *g,
void *data,
uint64_t event,
int event_handle,
int flags,
const char *buf, size_t buf_len,
const uint64_t *array, size_t array_len)
{
CAMLparam0 ();
CAMLlocal4 (evv, ehv, bufv, arrayv);
CAMLlocal2 (rv, v);
size_t i;
/* Only one bit should be set in 'event'. Which one? */
evv = Val_int (event_bitmask_to_event (event));
ehv = Val_int (event_handle);
bufv = caml_alloc_string (buf_len);
memcpy (String_val (bufv), buf, buf_len);
arrayv = caml_alloc (array_len, 0);
for (i = 0; i < array_len; ++i) {
v = caml_copy_int64 (array[i]);
Store_field (arrayv, i, v);
}
value args[4] = { evv, ehv, bufv, arrayv };
rv = caml_callbackN_exn (*(value*)data, 4, args);
/* Callbacks shouldn't throw exceptions. There's not much we can do
* except to print it.
*/
if (Is_exception_result (rv))
fprintf (stderr,
"libguestfs: uncaught OCaml exception in event callback: %s",
caml_format_exception (Extract_exception (rv)));
CAMLreturn0;
}
CAMLprim value iobuf_recvmmsg_ctx(value v_iobufs)
{
CAMLparam1(v_iobufs);
CAMLlocal4(v_iobuf, v_lo_min, v_hi_max, v_recvmmsg_ctx);
struct iovec * iovecs;
struct mmsghdr * hdrs;
unsigned i, count;
count = Wosize_val(v_iobufs);
iovecs = (struct iovec *) malloc(sizeof(struct iovec) * count);
hdrs = (struct mmsghdr *) malloc(sizeof(struct mmsghdr) * count);
for (i = 0; i<count; ++i) {
v_iobuf = Field(v_iobufs, i);
v_lo_min = Field(v_iobuf, iobuf_lo_min);
v_hi_max = Field(v_iobuf, iobuf_hi_max);
iovecs[i].iov_base = get_bstr(Field(v_iobuf, iobuf_buf), v_lo_min);
iovecs[i].iov_len = Long_val(v_hi_max) - Long_val(v_lo_min);
hdrs[i].msg_hdr.msg_name = 0;
hdrs[i].msg_hdr.msg_namelen = 0;
hdrs[i].msg_hdr.msg_iov = &iovecs[i];
hdrs[i].msg_hdr.msg_iovlen = 1;
hdrs[i].msg_hdr.msg_control = 0;
hdrs[i].msg_hdr.msg_controllen = 0;
hdrs[i].msg_hdr.msg_flags = 0;
/* We completely ignore msg_flags and ancillary data (msg_control)
for now. In the future, users may be interested in this. */
}
v_recvmmsg_ctx =
caml_alloc_custom(&recvmmsg_ctx_custom_ops, sizeof(recvmmsg_ctx), 0, 1);
Recvmmsg_ctx_ptr(v_recvmmsg_ctx)->iovecs = iovecs;
Recvmmsg_ctx_ptr(v_recvmmsg_ctx)->hdrs = hdrs;
CAMLreturn(v_recvmmsg_ctx);
}
CAMLprim value ml_gsl_poly_complex_solve_cubic(value a, value b, value c)
{
gsl_complex z0, z1, z2;
gsl_poly_complex_solve_cubic(Double_val(a), Double_val(b),
Double_val(c), &z0, &z1, &z2);
{
CAMLparam0();
CAMLlocal4(r,rz0, rz1, rz2);
rz0 = alloc_small(2 * Double_wosize, Double_array_tag);
Store_double_field(rz0, 0, GSL_REAL(z0));
Store_double_field(rz0, 1, GSL_IMAG(z0));
rz1 = alloc_small(2 * Double_wosize, Double_array_tag);
Store_double_field(rz1, 0, GSL_REAL(z1));
Store_double_field(rz1, 1, GSL_IMAG(z1));
rz2 = alloc_small(2 * Double_wosize, Double_array_tag);
Store_double_field(rz2, 0, GSL_REAL(z2));
Store_double_field(rz2, 1, GSL_IMAG(z2));
r = alloc_small(3, 0);
Field(r,0) = rz0 ;
Field(r,1) = rz1 ;
Field(r,2) = rz2 ;
CAMLreturn(r);
}
}
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);
}
value ml_lua_modinfo (value string)
{
CAMLparam1 (string);
CAMLlocal4 (name, version, depends, tuple);
int err, i, n;
lua_State *L = luaL_newstate();
luaL_openlibs(L);
err = luaL_dostring (L, String_val(string));
if (err != 0) {
caml_failwith("Lua.modinfo");
}
name = caml_alloc_string(0);
version = caml_alloc_string(0);
depends = caml_alloc_tuple(0);
lua_pushnil(L);
while (lua_next(L, -2) != 0) {
const char *s = lua_tostring(L, -2);
// Get name string
if (strcasecmp(s, "name") == 0) {
const char *s = lua_tostring(L, -1);
name = caml_copy_string(s);
}
// Get depends array
else if (strcasecmp(s, "depend") == 0) {
lua_pushstring(L, "table");
lua_gettable(L, LUA_GLOBALSINDEX);
lua_pushstring(L, "getn");
lua_gettable(L, -2);
lua_pushvalue(L, -3);
lua_call(L, 1, 1);
n = lua_tonumber(L, -1);
lua_pop(L, 2);
depends = caml_alloc_tuple(n);
i = 0;
lua_pushnil(L);
while (lua_next(L, -2) != 0) {
const char *s = lua_tostring(L, -1);
Store_field(depends, i, caml_copy_string(s));
i++;
lua_pop(L, 1);
}
}
// Get version string
else if (strcasecmp(s, "version") == 0) {
const char *s = lua_tostring(L, -1);
version = caml_copy_string(s);
}
lua_pop(L, 1);
}
tuple = caml_alloc_tuple(3);
Store_field(tuple, 0, name);
Store_field(tuple, 1, version);
Store_field(tuple, 2, depends);
CAMLreturn (tuple);
}
extern "C" void
monda_val_print (struct type* type, struct frame_info* frame,
int embedded_offset, CORE_ADDR address,
struct ui_file* stream, int recurse, struct value* val,
const struct value_print_options* options, int depth,
int max_string_length, int only_print_short_type,
int only_print_short_value)
{
CAMLparam0();
CAMLlocal4(v_type, v_stream, v_value, v_search_path);
CAMLlocal2(v_val, v_frame);
CAMLlocalN(args, 12);
static caml_value* callback = NULL;
int is_synthetic_pointer;
const gdb_byte* valaddr;
/* The try/catch is required so we don't leave local roots incorrectly
registered in the case of an exception.
We also ensure that any GDB function we call from the OCaml code
invoked below (via [caml_callbackN]) never throws any exceptions
across the OCaml -> C boundary. If it were to, then we would fail to
run the second part of the [caml_start_program] code, causing global
variables (e.g. [caml_last_return_address]) to be set incorrectly. */
TRY {
if (callback == NULL) {
callback = caml_named_value("From_gdb_ocaml.print_value");
assert (callback != NULL);
}
valaddr = value_contents_for_printing(val);
v_value =
(valaddr == NULL) ? caml_copy_nativeint(0)
: caml_copy_nativeint(*(intnat*) valaddr);
/* Determine whether the value is actually a construction made up in the
debugger's address space by virtue of interpreting DW_OP_implicit_pointer.
The second part of this conditional is really just a sanity check.
*/
is_synthetic_pointer =
(value_lval_const(val) == lval_computed
&& value_bits_synthetic_pointer(val, 0, sizeof(CORE_ADDR) * 8));
/*
fprintf(stderr, "monda_val_print. SP %d *valaddr=%p v_value=%p value_lval_const=%d lval_funcs=%p lazy=%d\n",
is_synthetic_pointer,
(void*) *(intnat*) valaddr,
(void*) v_value,
(int) (value_lval_const(val)),
value_lval_const(val) == lval_computed ? value_computed_funcs(val) : NULL,
value_lazy(val));
*/
/* CR mshinwell: improve this test */
#if 0
if ((TYPE_NAME(type) == NULL && !is_synthetic_pointer)
|| (is_synthetic_pointer && TYPE_CODE(type) != TYPE_CODE_PTR)) {
/*
fprintf(stderr, "monda_val_print -> c_val_print (1)\n");
fflush(stderr);
*/
c_val_print(type, frame, valaddr, embedded_offset, address, stream,
recurse, val, options, depth);
}
else
#endif
{
v_type = caml_copy_string(TYPE_NAME(type) == NULL ? "" : TYPE_NAME(type));
v_stream = caml_copy_int64((uint64_t) stream);
v_search_path = caml_copy_string(""); /* CR mshinwell: remove */
v_val = caml_copy_nativeint((intnat) val);
v_frame = caml_copy_nativeint((intnat) frame);
/* N.B. [Store_field] must not be used on [args]! */
args[0] = Val_bool(is_synthetic_pointer);
args[1] = v_value;
args[2] = v_val;
args[3] = v_stream;
args[4] = v_type;
args[5] = Val_bool(options->summary);
args[6] = Val_long(depth);
args[7] = Val_long(max_string_length);
args[8] = v_search_path;
args[9] = Val_bool(only_print_short_type);
args[10] = Val_bool(only_print_short_value);
args[11] = v_frame;
/*
fprintf(stderr, "monda_val_print -> OCaml printer. Type '%s'\n", TYPE_NAME(type));
fflush(stderr);
*/
/* CR mshinwell: This should catch any OCaml exceptions. */
if (caml_callbackN(*callback, 12, args) == Val_false) {
/*
fprintf(stderr, "monda_val_print -> c_val_print (2)\n");
fflush(stderr);
*/
c_val_print (type, frame, embedded_offset, address, stream, recurse,
val, options);
}
}
}
CATCH (exn, RETURN_MASK_ALL) {
fprintf(stderr, "monda_val_print: exception: %s\n",
exn.message ? exn.message : "<no message>");
CAMLdrop;
throw_exception(exn);
}
value spoc_getCudaDevice(value i)
{
CAMLparam1(i);
CAMLlocal4(general_info, cuda_info, specific_info, gc_info);
CAMLlocal3(device, maxT, maxG);
int nb_devices;
CUdevprop dev_infos;
CUdevice dev;
CUcontext ctx;
CUstream queue[2];
spoc_cu_context *spoc_ctx;
//CUcontext gl_ctx;
char infoStr[1024];
int infoInt;
size_t infoUInt;
int major, minor;
enum cudaError_enum cuda_error;
cuDeviceGetCount (&nb_devices);
if ((Int_val(i)) > nb_devices)
raise_constant(*caml_named_value("no_cuda_device")) ;
CUDA_CHECK_CALL(cuDeviceGet(&dev, Int_val(i)));
CUDA_CHECK_CALL(cuDeviceGetProperties(&dev_infos, dev));
general_info = caml_alloc (9, 0);
CUDA_CHECK_CALL(cuDeviceGetName(infoStr, sizeof(infoStr), dev));
Store_field(general_info,0, copy_string(infoStr));//
CUDA_CHECK_CALL(cuDeviceTotalMem(&infoUInt, dev));
Store_field(general_info,1, Val_int(infoUInt));//
Store_field(general_info,2, Val_int(dev_infos.sharedMemPerBlock));//
Store_field(general_info,3, Val_int(dev_infos.clockRate));//
Store_field(general_info,4, Val_int(dev_infos.totalConstantMemory));//
CUDA_CHECK_CALL(cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_MULTIPROCESSOR_COUNT, dev));
Store_field(general_info,5, Val_int(infoInt));//
CUDA_CHECK_CALL(cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_ECC_ENABLED, dev));
Store_field(general_info,6, Val_bool(infoInt));//
Store_field(general_info,7, i);
CUDA_CHECK_CALL(cuCtxCreate (&ctx,
CU_CTX_SCHED_BLOCKING_SYNC | CU_CTX_MAP_HOST,
dev));
spoc_ctx = malloc(sizeof(spoc_cl_context));
spoc_ctx->ctx = ctx;
CUDA_CHECK_CALL(cuStreamCreate(&queue[0], 0));
CUDA_CHECK_CALL(cuStreamCreate(&queue[1], 0));
spoc_ctx->queue[0] = queue[0];
spoc_ctx->queue[1] = queue[1];
Store_field(general_info,8, (value)spoc_ctx);
CUDA_CHECK_CALL(cuCtxSetCurrent(ctx));
cuda_info = caml_alloc(1, 0); //0 -> Cuda
specific_info = caml_alloc(18, 0);
cuDeviceComputeCapability(&major, &minor, dev);
Store_field(specific_info,0, Val_int(major));//
Store_field(specific_info,1, Val_int(minor));//
Store_field(specific_info,2, Val_int(dev_infos.regsPerBlock));//
Store_field(specific_info,3, Val_int(dev_infos.SIMDWidth));//
Store_field(specific_info,4, Val_int(dev_infos.memPitch));//
Store_field(specific_info,5, Val_int(dev_infos.maxThreadsPerBlock));//
maxT = caml_alloc(3, 0);
Store_field(maxT,0, Val_int(dev_infos.maxThreadsDim[0]));//
Store_field(maxT,1, Val_int(dev_infos.maxThreadsDim[1]));//
Store_field(maxT,2, Val_int(dev_infos.maxThreadsDim[2]));//
Store_field(specific_info,6, maxT);
maxG = caml_alloc(3, 0);
Store_field(maxG,0, Val_int(dev_infos.maxGridSize[0]));//
Store_field(maxG,1, Val_int(dev_infos.maxGridSize[1]));//
Store_field(maxG,2, Val_int(dev_infos.maxGridSize[2]));//
Store_field(specific_info,7, maxG);
Store_field(specific_info,8, Val_int(dev_infos.textureAlign));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_GPU_OVERLAP, dev);
Store_field(specific_info,9, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_KERNEL_EXEC_TIMEOUT, dev);
Store_field(specific_info,10, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_INTEGRATED, dev);
Store_field(specific_info,11, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_CAN_MAP_HOST_MEMORY, dev);
Store_field(specific_info,12, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_COMPUTE_MODE, dev);
Store_field(specific_info,13, Val_int(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_CONCURRENT_KERNELS, dev);
Store_field(specific_info,14, Val_bool(infoInt));//
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_PCI_BUS_ID, dev);
Store_field(specific_info,15, Val_int(infoInt));
cuDeviceGetAttribute(&infoInt, CU_DEVICE_ATTRIBUTE_PCI_DEVICE_ID, dev);
Store_field(specific_info,16, Val_int(infoInt));
cuDriverGetVersion(&infoInt);
Store_field(specific_info, 17, Val_int(infoInt));
Store_field(cuda_info, 0, specific_info);
device = caml_alloc(4, 0);
Store_field(device, 0, general_info);
Store_field(device, 1, cuda_info);
{spoc_cuda_gc_info* gcInfo = (spoc_cuda_gc_info*)malloc(sizeof(spoc_cuda_gc_info));
CUDA_CHECK_CALL(cuMemGetInfo(&infoUInt, NULL));
infoUInt -= (32*1024*1024);
Store_field(device, 2, (value)gcInfo);
{cuda_event_list* events = NULL;
Store_field(device, 3, (value)events);
CAMLreturn(device);}}
}
CAMLexport char * caml_format_exception(value exn)
{
mlsize_t start, i;
struct stringbuf buf;
char intbuf[64];
char * res;
CAMLparam1(exn);
CAMLlocal4(bucket, v, exnclass, field1);
buf.ptr = buf.data;
buf.end = buf.data + sizeof(buf.data) - 1;
/* An exception class is a value with tag Object_tag, whose first
field is a string naming the exception.
Exceptions that take parameters (e.g. Invalid_argument) are blocks
with tag 0, where the first field is the exception class.
Exceptions without parameters (e.g. Not_found) are just the exception
class. */
if (Tag_val(exn) == 0) {
/* Field 0 of exn is the exception class, which is immutable */
exnclass = Field_imm(exn, 0);
add_string(&buf, String_val(Field_imm(exnclass, 0)));
/* Check for exceptions in the style of Match_failure and Assert_failure */
if (Wosize_val(exn) == 2) {
caml_read_field(exn, 1, &field1);
} else {
field1 = Val_unit;
}
if (Is_block(field1) &&
Tag_val(field1) == 0 &&
caml_is_special_exception(exnclass)) {
bucket = field1;
start = 0;
} else {
bucket = exn;
start = 1;
}
add_char(&buf, '(');
for (i = start; i < Wosize_val(bucket); i++) {
if (i > start) add_string(&buf, ", ");
caml_read_field(bucket, i, &v);
if (Is_long(v)) {
snprintf(intbuf, sizeof(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, ')');
} else {
/* Exception without parameters */
exnclass = exn;
add_string(&buf, String_val(Field_imm(exnclass, 0)));
}
*buf.ptr = 0; /* Terminate string */
i = buf.ptr - buf.data + 1;
res = malloc(i);
if (res == NULL) CAMLreturnT (char*, NULL);
memmove(res, buf.data, i);
CAMLreturnT (char*, res);
}
CAMLprim value wrapLALInferenceFreqDomainStudentTLogLikelihood(value options, value IFOData, value params) {
CAMLparam3(options, IFOData, params);
CAMLlocal4(option, nsparams, sparams, vlogL);
LALPNOrder PhaseOrder=LAL_PNORDER_THREE_POINT_FIVE;
LALInferenceVariables LIparams;
double Mc, eta, m1, m2;
double distance;
double inclination, cos_i, dec;
double polarization, phase, t, ra;
double logL = 0.0;
long nseg;
double nu;
LALInferenceIFOData * data = (*(LALInferenceIFOData **)Data_custom_val(IFOData));
LALInferenceIFOData *currentData = data;
LIparams.dimension = 0;
LIparams.head = NULL;
option = Field(options, 0);
nseg = Long_val(option);
nu = 4.0 / M_PI * nseg;
currentData = data;
while (currentData != NULL) {
const size_t LEN = 64; /* Comes from LALInferenceLikelihood.c */
char dofname[LEN];
snprintf(dofname, LEN, "df_%s", currentData->name);
LALInferenceAddVariable(&LIparams, dofname, &nu, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_FIXED);
currentData = currentData->next;
}
/* Extract the non-spinning parameters. */
nsparams = Field(params, 0);
/* Masses. */
m1 = Double_field(nsparams, 0);
m2 = Double_field(nsparams, 1);
eta = m1*m2/(m1+m2)/(m1+m2);
Mc = (m1+m2)*pow(eta, 3.0/5.0);
LALInferenceAddVariable(&LIparams, "chirpmass", &Mc, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
LALInferenceAddVariable(&LIparams, "massratio", &eta, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
distance = Double_field(nsparams, 2);
LALInferenceAddVariable(&LIparams, "distance", &distance, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
cos_i = Double_field(nsparams, 3);
inclination = acos(cos_i);
LALInferenceAddVariable(&LIparams, "inclination", &inclination, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
polarization = Double_field(nsparams, 4);
LALInferenceAddVariable(&LIparams, "polarisation", &polarization, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR);
phase = Double_field(nsparams, 5);
LALInferenceAddVariable(&LIparams, "phase", &phase, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR);
t = Double_field(nsparams, 6);
LALInferenceAddVariable(&LIparams, "time", &t, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
ra = Double_field(nsparams, 7);
LALInferenceAddVariable(&LIparams, "rightascension", &ra, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR);
dec = asin(Double_field(nsparams, 8));
LALInferenceAddVariable(&LIparams, "declination", &dec, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
LALInferenceAddVariable(&LIparams, "LAL_PNORDER", &PhaseOrder, LALINFERENCE_UINT4_t, LALINFERENCE_PARAM_FIXED);
if (Tag_val(params) == 0) {
/* Non-spinning parameters. Run with TaylorF2 template. */
Approximant approx = TaylorF2;
LALInferenceAddVariable(&LIparams, "LAL_APPROXIMANT", &approx, LALINFERENCE_UINT4_t, LALINFERENCE_PARAM_FIXED);
caml_release_runtime_system();
logL = LALInferenceFreqDomainStudentTLogLikelihood(&LIparams, data, &LALInferenceTemplateLAL);
caml_acquire_runtime_system();
} else {
double a1, a2, costilt1, costilt2, myphi1, myphi2, theta1, theta2, phi1, phi2;
Approximant approx = SpinTaylorFrameless;
LALInferenceAddVariable(&LIparams, "LAL_APPROXIMANT", &approx, LALINFERENCE_UINT4_t, LALINFERENCE_PARAM_FIXED);
sparams = Field(params, 1);
a1 = Double_field(sparams, 0);
LALInferenceAddVariable(&LIparams, "a_spin1", &a1, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
a2 = Double_field(sparams, 1);
LALInferenceAddVariable(&LIparams, "a_spin2", &a2, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
costilt1 = Double_field(sparams, 2);
myphi1 = Double_field(sparams, 3);
theta_phi_template(&theta1, &phi1, cos_i, costilt1, myphi1);
LALInferenceAddVariable(&LIparams, "theta_spin1", &theta1, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
LALInferenceAddVariable(&LIparams, "phi_spin1", &phi1, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR);
costilt2 = Double_field(sparams, 4);
myphi2 = Double_field(sparams, 5);
theta_phi_template(&theta2, &phi2, cos_i, costilt2, myphi2);
LALInferenceAddVariable(&LIparams, "theta_spin2", &theta2, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR);
LALInferenceAddVariable(&LIparams, "phi_spin2", &phi2, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR);
caml_release_runtime_system();
logL = LALInferenceFreqDomainStudentTLogLikelihood(&LIparams, data, &LALInferenceTemplateLALGenerateInspiral);
caml_acquire_runtime_system();
}
vlogL = caml_copy_double(logL);
LALInferenceDestroyVariables(&LIparams);
CAMLreturn(vlogL);
}
