CAMLprim value caml_int32_compare(value v1, value v2)
{
int32 i1 = Int32_val(v1);
int32 i2 = Int32_val(v2);
int res = (i1 > i2) - (i1 < i2);
return Val_int(res);
}
CAMLprim value caml_int32_mod(value v1, value v2)
{
int32 dividend = Int32_val(v1);
int32 divisor = Int32_val(v2);
if (divisor == 0) caml_raise_zero_divide();
/* PR#4740: on some processors, modulus crashes if division overflows.
Implement the same behavior as for type "int". */
if (dividend == (1<<31) && divisor == -1) return caml_copy_int32(0);
#ifdef NONSTANDARD_DIV_MOD
return caml_copy_int32(caml_safe_mod(dividend, divisor));
#else
return caml_copy_int32(dividend % divisor);
#endif
}
CAMLprim value
caml_sfIpAddress_fromInteger(value int_addr)
{
sfUint32 address = Int32_val(int_addr);
sfIpAddress addr = sfIpAddress_fromInteger(address);
return Val_sfIpAddress(addr);
}
CAMLprim value ml_gdk_property_change (value window, value property, value type,
value mode, value xdata)
{
int format = Xdata_val (Field(xdata,0));
value data = Field(xdata,1);
int nelems = (format == 8 ? string_length (data) : Wosize_val(data));
guchar *sdata;
int i;
switch (format) {
case 16:
sdata = calloc(nelems, sizeof(short));
for (i=0; i<nelems; i++)
((gushort*)sdata)[i] = Int_val(Field(data,i));
break;
case 32:
sdata = calloc(nelems, sizeof(long));
for (i=0; i<nelems; i++)
((gulong*)sdata)[i] = Int32_val(Field(data,i));
break;
default:
sdata = (guchar*)data;
}
gdk_property_change (GdkWindow_val(window), GdkAtom_val(property),
GdkAtom_val(type), format, Property_mode_val(mode),
sdata, nelems);
if (format != 8) free(sdata);
return Val_unit;
}
/* Bind a UDP socket to a local v4 addr and return it */
CAMLprim value
caml_udpv4_bind(value v_ipaddr, value v_port)
{
CAMLparam2(v_ipaddr, v_port);
CAMLlocal2(v_ret, v_err);
int s = socket(PF_INET, SOCK_DGRAM, 0);
if (s < 0) {
v_err = caml_copy_string(strerror(errno));
Val_Err(v_ret, v_err);
CAMLreturn(v_ret);
}
setnonblock(s);
struct sockaddr_in sa;
bzero(&sa, sizeof sa);
sa.sin_family = AF_INET;
sa.sin_addr.s_addr = ntohl(Int32_val(v_ipaddr));
sa.sin_port = htons(Int_val(v_port));
int r = bind(s, (struct sockaddr *)&sa, sizeof(struct sockaddr));
if (r < 0) {
v_err = caml_copy_string(strerror(errno));
Val_Err(v_ret, v_err);
close(s);
CAMLreturn(v_ret);
}
Val_OK(v_ret, Val_int(s));
CAMLreturn(v_ret);
}
CAMLprim value
caml_udpv4_sendto(value v_fd, value v_str, value v_off, value v_len, value v_dst)
{
CAMLparam5(v_fd, v_str, v_off, v_len, v_dst);
CAMLlocal2(v_ret, v_err);
unsigned char *buf = String_val(v_str) + Int_val(v_off);
size_t len = Int_val(v_len);
int fd = Int_val(v_fd);
struct sockaddr_in sa;
socklen_t sa_len = sizeof(sa);
bzero(&sa, sizeof sa);
sa.sin_family = AF_INET;
sa.sin_addr.s_addr = htonl(Int32_val(Field(v_dst, 0)));
sa.sin_port = htons(Int_val(Field(v_dst, 1)));
int r = sendto(fd, buf, len, MSG_DONTWAIT, (struct sockaddr *)&sa, sa_len);
if (r < 0) {
if (errno == EAGAIN || errno==EWOULDBLOCK)
Val_WouldBlock(v_ret);
else {
v_err = caml_copy_string(strerror(errno));
Val_Err(v_ret, v_err);
}
} else {
Val_OK(v_ret, Val_int(r));
}
CAMLreturn(v_ret);
}
CAMLprim value
caml_tcpv4_connect(value v_ipaddr, value v_port)
{
CAMLparam2(v_ipaddr, v_port);
CAMLlocal2(v_ret, v_err);
int s,r;
struct sockaddr_in sa;
bzero(&sa, sizeof sa);
sa.sin_family = AF_INET;
sa.sin_port = htons(Int_val(v_port));
sa.sin_addr.s_addr = ntohl(Int32_val(v_ipaddr));
s = socket(PF_INET, SOCK_STREAM, 0);
if (s < 0) {
v_err = caml_copy_string(strerror(errno));
Val_Err(v_ret, v_err);
CAMLreturn(v_ret);
}
setnonblock(s);
r = connect(s, (struct sockaddr *)&sa, sizeof(struct sockaddr));
if (r == 0 || (r == -1 && errno == EINPROGRESS)) {
Val_OK(v_ret, Val_int(s));
} else {
v_err = caml_copy_string(strerror(errno));
Val_Err(v_ret, v_err);
close(s);
}
CAMLreturn(v_ret);
}
value ml_crc32_update_int32 (value custom, value uint)
{
CAMLparam2 (custom, uint);
u_int32_t *context = crc32_custom_val(custom);
CrcUpdateUInt32 (context, Int32_val(uint));
CAMLreturn (Val_unit);
}
value
c_sprint_int32(value s, value index, value x) {
CAMLparam3 (s, index, x);
int32_t *p = (int32_t*) (String_val(s) + Int_val(index));
*p = (int32_t)Int32_val(x);
CAMLreturn (Val_unit);
}
static void
set_ipaddr(struct sockaddr *sa, value ipaddr)
{
struct sockaddr_in *sin = (struct sockaddr_in *)sa;
sin->sin_family = AF_INET;
sin->sin_addr.s_addr = Int32_val(ipaddr);
return;
}
void tbstub_change_cell(value caml_x, value caml_y, value caml_ch, value caml_fg, value caml_bg) {
CAMLparam5(caml_x, caml_y, caml_ch, caml_fg, caml_bg);
tb_change_cell(Int_val(caml_x), Int_val(caml_y), Int32_val(caml_ch), Int_val(caml_fg), Int_val(caml_bg));
CAMLreturn0;
}
CAMLprim value ml_pixelColor(value dst,value x,value y, value col)
{
SDL_Surface *sur= SDL_SURFACE(dst);
int r;
r=pixelColor(sur,Int_val(x),Int_val(y),Int32_val(col));
return Val_bool(r);
}
CAMLprim void caml_epoll_ctl_mod(value epfd, value fd, value flags)
{
struct epoll_event ev;
ev.events = Int32_val(flags);
ev.data.fd = Int_val(fd);
int ret = epoll_ctl(Int_val(epfd), EPOLL_CTL_MOD, Int_val(fd), &ev);
if (ret == -1) uerror("epoll_ctl_mod", Nothing);
return;
}
CAMLprim value
caml_gnttab_grant_access(value v_ref, value v_bs, value v_domid, value v_readonly)
{
CAMLparam4(v_ref, v_bs, v_domid, v_readonly);
grant_ref_t ref = Int32_val(v_ref);
char *page = String_val(Field(v_bs, 0)) + (Int_val(Field(v_bs,1)) / 8);
ASSERT(((unsigned long)page) % PAGE_SIZE == 0);
gnttab_grant_access(ref, page, Int_val(v_domid), Bool_val(v_readonly));
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;
}
CAMLprim value ml_filledCircleColor(value dst,value p,value ra, value col)
{
SDL_Surface *sur= SDL_SURFACE(dst);
SDL_Rect prect;
int r;
SDLRect_of_value(&prect,p);
r=filledCircleColor(sur,prect.x,prect.y,Int_val(ra),Int32_val(col));
return Val_bool(r);
}
CAMLprim value
caml_SDL_SetColorKey(value surface, value flag, value key)
{
/* TODO:
* You can pass SDL_RLEACCEL to enable RLE accelerated blits.
*/
int r = SDL_SetColorKey(
SDL_Surface_val(surface), Bool_val(flag), Int32_val(key));
if (r) caml_failwith("Sdlsurface.set_color_key");
return Val_unit;
}
CAMLprim value ml_characterColor(value dst,value p,value c,value color)
{
SDL_Surface *sur= SDL_SURFACE(dst);
SDL_Rect rect;
int r;
SDLRect_of_value(&rect,p);
r=characterColor(sur,rect.x,rect.y,(char) c,Int32_val(color));
return Val_bool(r);
}
CAMLprim value ml_stringColor(value dst,value p,value c,value color)
{
SDL_Surface *sur= SDL_SURFACE(dst);
SDL_Rect rect;
int r;
SDLRect_of_value(&rect,p);
r=stringColor(sur,rect.x,rect.y,String_val(c),Int32_val(color));
return Val_bool(r);
}
CAMLprim value ml_aaellipseColor(value dst,value p,value rp, value col)
{
SDL_Surface *sur= SDL_SURFACE(dst);
SDL_Rect prect,rprect;
int r;
SDLRect_of_value(&prect,p);
SDLRect_of_value(&rprect,rp);
r=aaellipseColor(sur,prect.x,prect.y,rprect.x,rprect.y,Int32_val(col));
return Val_bool(r);
}
CAMLprim value ml_boxColor(value dst,value p1,value p2, value col)
{
SDL_Surface *sur= SDL_SURFACE(dst);
SDL_Rect rect1,rect2;
int r;
SDLRect_of_value(&rect1,p1);
SDLRect_of_value(&rect2,p2);
r=boxColor(sur,rect1.x,rect1.y,rect2.x,rect2.y,Int32_val(col));
return Val_bool(r);
}
CAMLprim value netsys_s_read_string_array(value sv, value pv, value lv,
value mv, value av)
{
char *s;
long p, l, n, k;
unsigned int e, j, m;
value uv;
int av_in_heap;
int err;
value r;
value **old_reftbl;
CAMLparam2(sv,av);
/* fprintf(stderr, "netsys_s_read_string_array\n"); fflush(stderr); */
s = String_val(sv); /* will have to redo after each allocation */
p = Long_val(pv);
l = Long_val(lv) + p;
m = (unsigned int) Int32_val(mv);
n = Wosize_val(av);
av_in_heap = (n > 5000) || (Long_val(lv) > 20000);
/* If av is already in the major heap, it is an extra burden to allocate
the new string in the minor heap. The new string would be a local
root until the next minor collection. We avoid this by allocating the
new string in the major heap directly if av is already there.
we don't have access to the Is_in_heap macro, so we just guess
it here
*/
err = 0;
k = 0;
while (k < n) {
if (p+4 > l) break;
e = ntohl(*((unsigned int *) (s+p)));
/* fprintf(stderr, "e=%u\n", e); fflush(stderr); */
p += 4;
j = l-p;
if (e > j) { err=-1; break; }
if (e > m) { err=-2; break; }
uv = av_in_heap ? netsys_alloc_string_shr(e) : caml_alloc_string(e);
s = String_val(sv); /* see above */
memcpy(String_val(uv), s+p, e);
caml_modify(&Field(av,k), uv);
p += e;
if ((e&3) != 0) p += 4-(e&3);
k++;
}
r = Val_long(err);
if (k >= n) r = Val_long(p);
CAMLreturn(r);
}
/* 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);
}
static int domain_create_info_val (caml_gc *gc, libxl_domain_create_info *c_val, value v)
{
CAMLparam1(v);
CAMLlocal1(a);
uint8_t *uuid = libxl_uuid_bytearray(&c_val->uuid);
int i;
c_val->hvm = Bool_val(Field(v, 0));
c_val->hap = Bool_val(Field(v, 1));
c_val->oos = Bool_val(Field(v, 2));
c_val->ssidref = Int32_val(Field(v, 3));
c_val->name = dup_String_val(gc, Field(v, 4));
a = Field(v, 5);
for (i = 0; i < 16; i++)
uuid[i] = Int_val(Field(a, i));
string_string_tuple_array_val(gc, &(c_val->xsdata), Field(v, 6));
string_string_tuple_array_val(gc, &(c_val->platformdata), Field(v, 7));
c_val->poolid = Int32_val(Field(v, 8));
c_val->poolname = dup_String_val(gc, Field(v, 9));
CAMLreturn(0);
}
CAMLprim value
caml_SDL_FillRect(
value dst,
value rect,
value color)
{
SDL_Rect _rect;
SDL_Rect_val(&_rect, rect);
int r = SDL_FillRect(
SDL_Surface_val(dst), &_rect,
Int32_val(color));
if (r) caml_failwith("Sdlsurface.fill_rect");
return Val_unit;
}
CAMLprim value do_cpuid(value leaf, value word)
{
int32_t eax, ebx, ecx, edx, tmp;
CAMLparam2(leaf, word);
CAMLlocal1(rv);
eax = Int32_val(leaf);
ecx = Int32_val(word);
/* Execute CPUID; the MOVs are because ocamlc uses -fPIC and
* 32-bit gcc won't let you just use "=b" to get at %ebx in PIC */
asm("mov %%ebx, %4 ; cpuid ; mov %%ebx, %1 ; mov %4, %%ebx "
: "+a" (eax), "=r" (ebx), "+c" (ecx), "=d" (edx), "=r" (tmp));
/* Wrap the return value up as an OCaml tuple */
rv = caml_alloc_tuple(4);
Store_field(rv, 0, caml_copy_int32(eax));
Store_field(rv, 1, caml_copy_int32(ebx));
Store_field(rv, 2, caml_copy_int32(ecx));
Store_field(rv, 3, caml_copy_int32(edx));
CAMLreturn(rv);
}
CAMLprim value caml_int32_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_INT32_PRINTF_FORMAT,
format_string, default_format_buffer, &conv);
sprintf(buffer, format_string, Int32_val(arg));
res = caml_copy_string(buffer);
if (buffer != default_format_buffer) caml_stat_free(buffer);
return res;
}
CAMLprim value c_to_caml_epoll_event_flags(value flags)
{
CAMLparam0();
CAMLlocal2(res, tmp);
res = Val_int(0);
int register i;
int iflags = Int32_val(flags);
for(i = 0; i < NUM_EPOLL_EVENTS; i++){
if( iflags & caml_epoll_events[i] ){
tmp = caml_alloc_small(2, 0);
Field(tmp, 0) = Val_int(i);
Field(tmp, 1) = res;
res = tmp;
}
}
CAMLreturn(res);
}
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
caml_gnttab_end_access(value v_ref)
{
CAMLparam1(v_ref);
grant_ref_t ref = Int32_val(v_ref);
uint16_t flags, nflags;
BUG_ON(ref >= NR_GRANT_ENTRIES || ref < NR_RESERVED_ENTRIES);
nflags = gnttab_table[ref].flags;
do {
if ((flags = nflags) & (GTF_reading|GTF_writing)) {
printk("WARNING: g.e. %d still in use! (%x)\n", ref, flags);
CAMLreturn(Val_unit);
}
} while ((nflags = synch_cmpxchg(&gnttab_table[ref].flags, flags, 0)) !=
flags);
CAMLreturn(Val_unit);
}