CAMLprim value netsys_fallocate(value fd, value start, value len) {
#ifdef HAVE_POSIX_FALLOCATE
int r;
int64 start_int, len_int;
off_t start_off, len_off;
/* Att: off_t might be 64 bit even on 32 bit systems! */
start_int = Int64_val(start);
len_int = Int64_val(len);
if ( ((int64) ((off_t) start_int)) != start_int )
failwith("Netsys.fadvise: large files not supported on this OS");
if ( ((int64) ((off_t) len_int)) != len_int )
failwith("Netsys.fadvise: large files not supported on this OS");
start_off = start_int;
len_off = len_int;
r = posix_fallocate(Int_val(fd), start_off, len_off);
/* does not set errno! */
if (r != 0)
unix_error(r, "posix_fallocate64", Nothing);
return Val_unit;
#else
invalid_argument("Netsys.fallocate not available");
#endif
}
static int domain_build_info_val (caml_gc *gc, libxl_domain_build_info *c_val, value v)
{
CAMLparam1(v);
CAMLlocal1(infopriv);
c_val->max_vcpus = Int_val(Field(v, 0));
c_val->cur_vcpus = Int_val(Field(v, 1));
c_val->max_memkb = Int64_val(Field(v, 2));
c_val->target_memkb = Int64_val(Field(v, 3));
c_val->video_memkb = Int64_val(Field(v, 4));
c_val->shadow_memkb = Int64_val(Field(v, 5));
c_val->kernel.path = dup_String_val(gc, Field(v, 6));
c_val->is_hvm = Tag_val(Field(v, 7)) == 0;
infopriv = Field(Field(v, 7), 0);
if (c_val->hvm) {
c_val->u.hvm.pae = Bool_val(Field(infopriv, 0));
c_val->u.hvm.apic = Bool_val(Field(infopriv, 1));
c_val->u.hvm.acpi = Bool_val(Field(infopriv, 2));
c_val->u.hvm.nx = Bool_val(Field(infopriv, 3));
c_val->u.hvm.viridian = Bool_val(Field(infopriv, 4));
c_val->u.hvm.timeoffset = dup_String_val(gc, Field(infopriv, 5));
c_val->u.hvm.timer_mode = Int_val(Field(infopriv, 6));
c_val->u.hvm.hpet = Int_val(Field(infopriv, 7));
c_val->u.hvm.vpt_align = Int_val(Field(infopriv, 8));
} else {
c_val->u.pv.slack_memkb = Int64_val(Field(infopriv, 0));
c_val->u.pv.cmdline = dup_String_val(gc, Field(infopriv, 1));
c_val->u.pv.ramdisk.path = dup_String_val(gc, Field(infopriv, 2));
c_val->u.pv.features = dup_String_val(gc, Field(infopriv, 3));
}
CAMLreturn(0);
}
CAMLprim value caml_int64_div(value v1, value v2)
{
int64 dividend = Int64_val(v1);
int64 divisor = Int64_val(v2);
if (I64_is_zero(divisor)) caml_raise_zero_divide();
/* PR#4740: on some processors, division crashes on overflow.
Implement the same behavior as for type "int". */
if (I64_is_min_int(dividend) && I64_is_minus_one(divisor)) return v1;
return caml_copy_int64(I64_div(Int64_val(v1), divisor));
}
static int domain_build_state_val(caml_gc *gc, libxl_domain_build_state *c_val, value v)
{
CAMLparam1(v);
c_val->store_port = Int_val(Field(v, 0));
c_val->store_mfn = Int64_val(Field(v, 1));
c_val->console_port = Int_val(Field(v, 2));
c_val->console_mfn = Int64_val(Field(v, 3));
CAMLreturn(0);
}
/* NB: "noalloc" function. */
value
guestfs_int_mllib_progress_bar_set (value barv,
value positionv, value totalv)
{
struct progress_bar *bar = Bar_val (barv);
uint64_t position = Int64_val (positionv);
uint64_t total = Int64_val (totalv);
progress_bar_set (bar, position, total);
return Val_unit;
}
CAMLprim value brlapiml_acceptKeyRanges(value handle, value camlRanges)
{
CAMLparam2(handle, camlRanges);
CAMLlocal1(r);
unsigned int i, size = Wosize_val(camlRanges);
brlapi_range_t ranges[size];
for (i=0; i<size; i++) {
r = Field(camlRanges, i);
ranges[i].first = Int64_val(Field(r, 0));
ranges[i].last = Int64_val(Field(r, 1));
}
brlapiCheckError(acceptKeyRanges, ranges, size);
CAMLreturn(Val_unit);
}
value tigertree_unsafe64_fd (value digest_v, value fd_v, value pos_v, value len_v)
{
OS_FD fd = Fd_val(fd_v);
OFF_T pos = Int64_val(pos_v);
OFF_T len = Int64_val(len_v);
unsigned char *digest = String_val(digest_v);
/* int nread; */
os_lseek(fd, pos, SEEK_SET);
tiger_tree_fd(fd, len, 0, tiger_block_size(len), digest);
return Val_unit;
}
CAMLprim value stub_blk_read(value sector, value buffer, value num) {
CAMLparam3(sector, buffer, num);
uint64_t sec = Int64_val(sector);
uint8_t *data = Caml_ba_data_val(buffer);
int n = Int_val(num);
int ret = 0;
assert(Caml_ba_array_val(buffer)->num_dims == 1);
//printf("Solo5 blk read: sec=%d num=%d\n", sec, n);
ret = solo5_blk_read_sync(sec, data, &n);
if ( ret )
printf("virtio read failed... %d from sector=%d\n", n, sec);
#if 0
{
int i;
for (i = 0; i < n; i++) {
printf("%02x ", (uint8_t) data[i]);
if ( i % 16 == 15 )
printf("\n");
}
printf("\n");
}
#endif
CAMLreturn(Val_bool(!ret));
}
CAMLprim value stub_sendfile64(value in_fd, value out_fd, value len){
CAMLparam3(in_fd, out_fd, len);
CAMLlocal1(result);
size_t c_len = Int64_val(len);
size_t bytes;
int c_in_fd = Int_val(in_fd);
int c_out_fd = Int_val(out_fd);
int rc = NOT_IMPLEMENTED;
enter_blocking_section();
#ifdef __linux__
rc = TRIED_AND_FAILED;
bytes = sendfile(c_out_fd, c_in_fd, NULL, c_len);
if (bytes != -1) rc = OK;
#endif
leave_blocking_section();
switch (rc) {
case NOT_IMPLEMENTED:
caml_failwith("This platform does not support sendfile()");
break;
case TRIED_AND_FAILED:
uerror("sendfile", Nothing);
break;
default: break;
}
result = caml_copy_int64(bytes);
CAMLreturn(result);
}
value
c_sprint_int64(value s, value index, value x) {
CAMLparam3 (s, index, x);
int64_t *p = (int64_t*) (String_val(s) + Int_val(index));
*p = (int64_t)Int64_val(x);
CAMLreturn (Val_unit);
}
/*
lseek is used inside Uwt_io. Therefore, I can't be seperated like the other
unix functions
*/
CAMLprim value
uwt_lseek(value o_fd, value o_pos, value o_mode, value o_loop, value o_cb)
{
CAMLparam1(o_cb);
int erg;
uv_loop_t * loop = Uv_loop_val(o_loop);
const int fd = FD_VAL(o_fd);
const int64_t offset = Int64_val(o_pos);
const int whence = seek_command_table[ Long_val(o_mode) ];
GR_ROOT_ENLARGE();
value o_ret;
struct req * req = uwt__req_create_res(UV_WORK, &o_ret);
req->buf.len = (size_t)fd;
req->offset = whence;
req->c_cb = lseek_cb;
int64_t_to_voids(offset,&req->c);
erg = uv_queue_work(loop, (uv_work_t*)req->req, lseek_work_cb, uwork_cb);
if ( erg >= 0 ){
uwt__gr_register(&req->cb,o_cb);
}
else {
uwt__req_free(req);
Field(o_ret,0) = Val_uwt_error(erg);
Tag_val(o_ret) = Error_tag;
}
CAMLreturn(o_ret);
}
CAMLprim value unix_lseek_64(value fd, value ofs, value cmd)
{
__int64 ret;
ret = caml_set_file_pointer(Handle_val(fd), Int64_val(ofs),
seek_command_table[Int_val(cmd)]);
return copy_int64(ret);
}
CAMLprim value caml_int64_float_of_bits(value vi)
{
union { double d; int64 i; int32 h[2]; } u;
u.i = Int64_val(vi);
#if defined(__arm__) && !defined(__ARM_EABI__)
{ int32 t = u.h[0]; u.h[0] = u.h[1]; u.h[1] = t; }
#endif
return caml_copy_double(u.d);
}
CAMLprim value brlapiml_acceptKeys(value handle, value rt, value camlKeys)
{
CAMLparam3(handle, rt, camlKeys);
unsigned int i, size = Wosize_val(camlKeys);
brlapi_keyCode_t keys[size];
for (i=0; i<size; i++) keys[i] = Int64_val(Field(camlKeys, i));
brlapiCheckError(acceptKeys, Int_val(rt), keys, size);
CAMLreturn(Val_unit);
}
CAMLprim value ocaml_gstreamer_buffer_set_presentation_time(value _buf, value _t)
{
CAMLparam2(_buf, _t);
GstBuffer *b = Buffer_val(_buf);
GstClockTime t = Int64_val(_t);
b->pts = t;
CAMLreturn(Val_unit);
}
value mld_ftruncate_64(value fd_v, value len_v, value sparse)
{
OFF_T len = Int64_val(len_v);
OS_FD fd = Fd_val(fd_v);
int use_sparse = Bool_val(sparse);
os_ftruncate(fd, len, use_sparse);
return Val_unit;
}
CAMLprim value ocaml_gstreamer_buffer_set_duration(value _buf, value _t)
{
CAMLparam2(_buf, _t);
GstBuffer *b = Buffer_val(_buf);
GstClockTime t = Int64_val(_t);
b->duration = t;
CAMLreturn(Val_unit);
}
static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
{
struct caml_ba_array * b = Caml_ba_array_val(vb);
intnat index[CAML_BA_MAX_NUM_DIMS];
int i;
intnat offset;
/* Check number of indices = number of dimensions of array
(maybe not necessary if ML typing guarantees this) */
if (nind != b->num_dims)
caml_invalid_argument("Bigarray.set: wrong number of indices");
/* Compute offset and check bounds */
for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
offset = caml_ba_offset(b, index);
/* Perform write */
switch (b->flags & CAML_BA_KIND_MASK) {
default:
Assert(0);
#ifdef _KERNEL
#else
case CAML_BA_FLOAT32:
((float *) b->data)[offset] = Double_val(newval); break;
case CAML_BA_FLOAT64:
((double *) b->data)[offset] = Double_val(newval); break;
#endif
case CAML_BA_SINT8:
case CAML_BA_UINT8:
((int8 *) b->data)[offset] = Int_val(newval); break;
case CAML_BA_SINT16:
case CAML_BA_UINT16:
((int16 *) b->data)[offset] = Int_val(newval); break;
case CAML_BA_INT32:
((int32 *) b->data)[offset] = Int32_val(newval); break;
case CAML_BA_INT64:
((int64 *) b->data)[offset] = Int64_val(newval); break;
case CAML_BA_NATIVE_INT:
((intnat *) b->data)[offset] = Nativeint_val(newval); break;
case CAML_BA_CAML_INT:
((intnat *) b->data)[offset] = Long_val(newval); break;
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
p[0] = Double_field(newval, 0);
p[1] = Double_field(newval, 1);
break; }
case CAML_BA_COMPLEX64:
{ double * p = ((double *) b->data) + offset * 2;
p[0] = Double_field(newval, 0);
p[1] = Double_field(newval, 1);
break; }
#endif
}
return Val_unit;
}
/* noalloc */
value bap_disasm_set_memory_stub(value d,
value base,
value data,
value off,
value len) {
bap_disasm_set_memory(Int_val(d),
Int64_val(base),
(const char *)Caml_ba_data_val(data),
Int_val(off),
Int_val(len));
return Val_unit;
}
CAMLprim value
caml_poll(value v_until)
{
CAMLparam1(v_until);
CAMLlocal1(work_to_do);
uint64_t until = (Int64_val(v_until));
int rc = solo5_poll(until);
work_to_do = Val_bool(rc);
CAMLreturn(work_to_do);
}
CAMLprim value setsockopt_stub(value sock, value sockopt, value val) {
CAMLparam3 (sock, sockopt, val);
int native_sockopt = Int_val(sockopt);
struct wrap *socket = Socket_val(sock);
int result = -1;
switch (native_sockopt) {
case ZMQ_SNDHWM:
case ZMQ_RCVHWM:
case ZMQ_RATE:
case ZMQ_RECOVERY_IVL:
case ZMQ_SNDBUF:
case ZMQ_RCVBUF:
case ZMQ_LINGER:
case ZMQ_RECONNECT_IVL_MAX:
case ZMQ_BACKLOG:
case ZMQ_MULTICAST_HOPS:
case ZMQ_RCVTIMEO:
case ZMQ_SNDTIMEO:
{
int optval = Int_val(val);
result = zmq_setsockopt(socket->wrapped, native_sockopt, &optval, sizeof(optval));
}
break;
case ZMQ_IDENTITY:
case ZMQ_SUBSCRIBE:
case ZMQ_UNSUBSCRIBE:
{
result = zmq_setsockopt(socket->wrapped,
native_sockopt,
String_val(val),
caml_string_length(val));
}
break;
case ZMQ_AFFINITY:
case ZMQ_MAXMSGSIZE:
{
int64 optval = Int64_val(val);
result = zmq_setsockopt(socket->wrapped, native_sockopt, &optval, sizeof(optval));
}
break;
default:
caml_failwith("Bidings error");
}
stub_raise_if (result == -1);
CAMLreturn (Val_unit);
}
CAMLexport value caml_copy_int64(int64 i)
{
value res = caml_alloc_custom(&caml_int64_ops, 8, 0, 1);
#ifndef ARCH_ALIGN_INT64
Int64_val(res) = i;
#else
union { int32 i[2]; int64 j; } buffer;
buffer.j = i;
((int32 *) Data_custom_val(res))[0] = buffer.i[0];
((int32 *) Data_custom_val(res))[1] = buffer.i[1];
#endif
return res;
}
CAMLprim value brlapiml_expandKeyCode(value handle, value camlKeyCode)
{
CAMLparam2(handle, camlKeyCode);
CAMLlocal1(result);
brlapi_expandedKeyCode_t ekc;
brlapiCheckError(expandKeyCode, Int64_val(camlKeyCode), &ekc);
result = caml_alloc_tuple(4);
Store_field(result, 0, caml_copy_int32(ekc.type));
Store_field(result, 1, caml_copy_int32(ekc.command));
Store_field(result, 2, caml_copy_int32(ekc.argument));
Store_field(result, 2, caml_copy_int32(ekc.flags));
CAMLreturn(result);
}
/* string_of_prim : 'a prim -> 'a -> string */
value ctypes_string_of_prim(value prim_, value v)
{
CAMLparam2(prim_, v);
CAMLlocal1(s);
char buf[64];
int len = 0;
switch (Int_val(prim_))
{
case Char: len = snprintf(buf, sizeof buf, "'%c'", Int_val(v)); break;
case Schar: len = snprintf(buf, sizeof buf, "%d", Int_val(v)); break;
case Uchar: len = snprintf(buf, sizeof buf, "%d", (unsigned char)Uint8_val(v)); break;
case Short: len = snprintf(buf, sizeof buf, "%hd", (short)Int_val(v)); break;
case Int: len = snprintf(buf, sizeof buf, "%d", Int_val(v)); break;
case Long: len = snprintf(buf, sizeof buf, "%ld", (long)ctypes_long_val(v)); break;
case Llong: len = snprintf(buf, sizeof buf, "%lld", (long long)ctypes_llong_val(v)); break;
case Ushort: len = snprintf(buf, sizeof buf, "%hu", (unsigned short)ctypes_ushort_val(v)); break;
case Uint: len = snprintf(buf, sizeof buf, "%u", (unsigned)ctypes_uint_val(v)); break;
case Ulong: len = snprintf(buf, sizeof buf, "%lu", (unsigned long)ctypes_ulong_val(v)); break;
case Ullong: len = snprintf(buf, sizeof buf, "%llu", (unsigned long long)ctypes_ullong_val(v)); break;
case Size_t: len = snprintf(buf, sizeof buf, "%zu", (size_t)ctypes_size_t_val(v)); break;
case Int8_t: len = snprintf(buf, sizeof buf, "%" PRId8, (int8_t)Int_val(v)); break;
case Int16_t: len = snprintf(buf, sizeof buf, "%" PRId16, (int16_t)Int_val(v)); break;
case Int32_t: len = snprintf(buf, sizeof buf, "%" PRId32, Int32_val(v)); break;
case Int64_t: len = snprintf(buf, sizeof buf, "%" PRId64, Int64_val(v)); break;
case Uint8_t: len = snprintf(buf, sizeof buf, "%" PRIu8, Uint8_val(v)); break;
case Uint16_t: len = snprintf(buf, sizeof buf, "%" PRIu16, Uint16_val(v)); break;
case Uint32_t: len = snprintf(buf, sizeof buf, "%" PRIu32, Uint32_val(v)); break;
case Uint64_t: len = snprintf(buf, sizeof buf, "%" PRIu64, Uint64_val(v)); break;
case Camlint: len = snprintf(buf, sizeof buf, "%" ARCH_INTNAT_PRINTF_FORMAT "d",
(intnat)Int_val(v)); break;
case Nativeint: len = snprintf(buf, sizeof buf, "%" ARCH_INTNAT_PRINTF_FORMAT "d",
(intnat)Nativeint_val(v)); break;
case Float: len = snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break;
case Double: len = snprintf(buf, sizeof buf, "%.12g", Double_val(v)); break;
case Complex32: {
float complex c = ctypes_float_complex_val(v);
len = snprintf(buf, sizeof buf, "%.12g+%.12gi", crealf(c), cimagf(c));
break;
}
case Complex64: {
double complex c = ctypes_double_complex_val(v);
len = snprintf(buf, sizeof buf, "%.12g+%.12gi", creal(c), cimag(c));
break;
}
default:
assert(0);
}
s = caml_alloc_string(len);
memcpy(String_val(s), buf, len);
CAMLreturn (s);
}
CAMLprim value caml_extunix_fadvise64(value vfd, value voff, value vlen, value vadvise)
{
int errcode = 0;
int fd = -1;
off64_t off = 0;
off64_t len = 0;
int advise = 0;
CAMLparam4(vfd, voff, vlen, vadvise);
fd = Int_val(vfd);
off = Int64_val(voff);
len = Int64_val(vlen);
advise = caml_advises[Int_val(vadvise)];
errcode = posix_fadvise64(fd, off, len, advise);
if (errcode != 0)
{
unix_error(errcode, "fadvise64", Nothing);
};
CAMLreturn(Val_unit);
}
CAMLprim value caml_int64_format(value fmt, value arg)
{
char format_string[FORMAT_BUFFER_SIZE];
char default_format_buffer[FORMAT_BUFFER_SIZE];
char * buffer;
char conv;
value res;
buffer = parse_format(fmt, ARCH_INT64_PRINTF_FORMAT,
format_string, default_format_buffer, &conv);
I64_format(buffer, format_string, Int64_val(arg));
res = caml_copy_string(buffer);
if (buffer != default_format_buffer) caml_stat_free(buffer);
return res;
}
/* The stub creating the job structure. */
CAMLprim value lwt_unix_lseek_64_job(value fd, value offset, value whence)
{
/* Allocate a new job. */
struct job_lseek* job = lwt_unix_new(struct job_lseek);
/* Initializes function fields. */
job->job.worker = (lwt_unix_job_worker)worker_lseek;
job->job.result = (lwt_unix_job_result)result_lseek_64;
/* Copy the fd parameter. */
job->fd = Int_val(fd);
/* Copy the offset parameter. */
job->offset = Int64_val(offset);
/* Copy the whence parameter. */
job->whence = seek_command_table[Int_val(whence)];
/* Wrap the structure into a caml value. */
return lwt_unix_alloc_job(&job->job);
}
void camlidl_ml2c_libbfd_struct_bfd_symbol(value _v1, struct bfd_symbol * _c2, camlidl_ctx _ctx)
{
value _v3;
value _v4;
value _v5;
value _v6;
value _v7;
_v3 = Field(_v1, 0);
camlidl_ml2c_libbfd_bfdp(_v3, &(*_c2).the_bfd, _ctx);
_v4 = Field(_v1, 1);
(*_c2).name = camlidl_malloc_string(_v4, _ctx);
_v5 = Field(_v1, 2);
(*_c2).value = Int64_val(_v5);
_v6 = Field(_v1, 3);
(*_c2).flags = Int_val(_v6);
_v7 = Field(_v1, 4);
camlidl_ml2c_libbfd_section_ptr(_v7, &(*_c2).section, _ctx);
}
value
guestfs_int_mllib_visit (value gv, value dirv, value fv)
{
CAMLparam3 (gv, dirv, fv);
value *visit_failure_exn;
guestfs_h *g = (guestfs_h *) (intptr_t) Int64_val (gv);
struct visitor_function_wrapper_args args;
/* The dir string could move around when we call the
* visitor_function, so we have to take a full copy of it.
*/
char *dir = strdup (String_val (dirv));
/* This stack address is used to point to the exception, if one is
* raised in the visitor_function.
*/
CAMLlocal1 (exn);
exn = Val_unit;
args.exnp = &exn;
args.fvp = &fv;
if (visit (g, dir, visitor_function_wrapper, &args) == -1) {
free (dir);
if (exn != Val_unit) {
/* The failure was caused by visitor_function raising an
* exception. Re-raise it here.
*/
caml_raise (exn);
}
/* Otherwise it's some other failure. The visit function has
* already printed the error to stderr (XXX - fix), so we raise a
* generic exception.
*/
visit_failure_exn = caml_named_value ("Visit.Failure");
caml_raise (*visit_failure_exn);
}
free (dir);
CAMLreturn (Val_unit);
}
CAMLprim value ocaml_gstreamer_element_seek_simple(value _e, value _fmt, value _flags, value _pos)
{
CAMLparam4(_e, _fmt, _flags, _pos);
GstElement *e = Element_val(_e);
GstFormat fmt = format_val(_fmt);
GstSeekFlags flags = 0;
gint64 pos = Int64_val(_pos);
gboolean ret;
int i;
for (i = 0; i < Wosize_val(_flags); i++)
flags |= seek_flags_val(Field(_flags,i));
caml_release_runtime_system();
ret = gst_element_seek_simple(e, fmt, flags, pos);
caml_acquire_runtime_system();
if (!ret) caml_raise_constant(*caml_named_value("gstreamer_exn_failure"));
CAMLreturn(Val_unit);
}
