CAMLprim value unix_lseek(value fd, value ofs, value cmd)
{
file_offset ret;
caml_enter_blocking_section();
ret = lseek(Int_val(fd), Long_val(ofs),
seek_command_table[Int_val(cmd)]);
caml_leave_blocking_section();
if (ret == -1) uerror("lseek", Nothing);
if (ret > Max_long) unix_error(EOVERFLOW, "lseek", Nothing);
return Val_long(ret);
}
CAMLprim value caml_ml_input_char(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
unsigned char c;
Lock(channel);
c = getch(channel);
Unlock(channel);
CAMLreturn (Val_long(c));
}
CAMLprim value bigstring_pwrite_assume_fd_is_nonblocking_stub(
value v_fd, value v_offset, value v_pos, value v_len, value v_bstr)
{
char *bstr = get_bstr(v_bstr, v_pos);
size_t len = Long_val(v_len);
ssize_t written;
written = pwrite(Int_val(v_fd), bstr, len, Long_val(v_offset));
if (written == -1) uerror("bigstring_pwrite_assume_fd_is_nonblocking_stub", Nothing);
return Val_long(written);
}
CAMLprim value hh_hash_used_slots(void) {
CAMLparam0();
uint64_t count = 0;
uintptr_t i = 0;
for (i = 0; i < hashtbl_size; ++i) {
if (hashtbl[i].addr != NULL) {
count++;
}
}
CAMLreturn(Val_long(count));
}
CAMLprim value caml_sys_get_config(value unit)
{
CAMLparam0 (); /* unit is unused */
CAMLlocal2 (result, ostype);
ostype = caml_copy_string(OCAML_OS_TYPE);
result = caml_alloc_small (2, 0);
Field(result, 0) = ostype;
Field(result, 1) = Val_long (8 * sizeof(value));
CAMLreturn (result);
}
CAMLprim value caml_ml_input_scan_line(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
intnat res;
Lock(channel);
res = caml_input_scan_line(channel);
Unlock(channel);
CAMLreturn (Val_long(res));
}
value svec_getvecword (value vec)
{
value res;
res = Val_long(*(unsigned int*) String_val(vec));
if (jit_ffi_debug)
fprintf(stderr,"svec_getvecword returning 0x%8.8x [0x%8.8x].\n",
(unsigned int) Long_val(res), * ((unsigned int*) (String_val(vec))));
return res;
}
static void invoke_completion_callback
(long id, long len, long errCode, long action) {
CAMLlocal2 (err, name);
value args[4];
err = Val_long(0);
if (errCode != NO_ERROR) {
len = -1;
win32_maperr (errCode);
err = unix_error_of_code(errno);
}
name = copy_string (action_name[action]);
D(printf("Action %s completed: id %ld -> len %ld / err %d (errCode %ld)\n",
action_name[action], id, len, errno, errCode));
args[0] = Val_long(id);
args[1] = Val_long(len);
args[2] = err;
args[3] = name;
caml_callbackN(completionCallback, 4, args);
D(printf("Callback performed\n"));
}
value int_of_string(value s) /* ML */
{
long res;
int sign;
int base;
char * p;
int c, d;
p = String_val(s);
if (*p == 0) failwith("int_of_string");
sign = 1;
if (*p == '-') {
sign = -1;
p++;
}
base = 10;
if (*p == '0') {
switch (p[1]) {
case 'x':
case 'X':
base = 16;
p += 2;
break;
case 'o':
case 'O':
base = 8;
p += 2;
break;
case 'b':
case 'B':
base = 2;
p += 2;
break;
}
}
res = 0;
while (1) {
c = *p;
if (c >= '0' && c <= '9')
d = c - '0';
else if (c >= 'A' && c <= 'F')
d = c - 'A' + 10;
else if (c >= 'a' && c <= 'f')
d = c - 'a' + 10;
else
break;
if (d >= base) break;
res = base * res + d;
p++;
}
if (*p != 0)
failwith("int_of_string");
return Val_long(sign < 0 ? -res : res);
}
CAMLprim value bigstring_pread_assume_fd_is_nonblocking_stub(
value v_fd, value v_offset, value v_pos, value v_len, value v_bstr)
{
char *bstr = get_bstr(v_bstr, v_pos);
size_t len = Long_val(v_len);
ssize_t n_read;
n_read = pread(Int_val(v_fd), bstr, len, Long_val(v_offset));
if (n_read == -1) uerror("bigstring_pread_assume_fd_is_nonblocking_stub", Nothing);
return Val_long(n_read);
}
value hh_dep_used_slots() {
CAMLparam0();
uint64_t count = 0;
uintptr_t slot = 0;
for (slot = 0; slot < DEP_SIZE; ++slot) {
if (deptbl[slot]) {
count++;
}
}
CAMLreturn(Val_long(count));
}
value hh_hash_used_slots() {
CAMLparam0();
uint64_t count = 0;
uintptr_t i = 0;
for (i = 0; i < HASHTBL_SIZE; ++i) {
if (hashtbl[i].addr != NULL) {
count++;
}
}
CAMLreturn(Val_long(count));
}
CAMLprim value caml_gc_major_slice (value v)
{
intnat res;
CAMLassert (Is_long (v));
caml_ev_pause(EV_PAUSE_GC);
caml_empty_minor_heap ();
res = caml_major_collection_slice(Long_val(v), 0);
caml_ev_resume();
caml_handle_gc_interrupt();
return Val_long (res);
}
CAMLprim value unix_lseek(value fd, value ofs, value cmd)
{
__int64 ret;
ret = caml_set_file_pointer(Handle_val(fd), Long_val(ofs),
seek_command_table[Int_val(cmd)]);
if (ret > Max_long) {
win32_maperr(ERROR_ARITHMETIC_OVERFLOW);
uerror("lseek", Nothing);
}
return Val_long(ret);
}
CAMLprim value netsys_s_read_int4_64(value sv, value pv)
{
char *s;
intnat p;
s = String_val(sv);
p = Long_val(pv);
/* careful: the result of ntohl is unsigned. We first have to
convert it to signed, then extend it to intnat.
*/
return Val_long((int) (ntohl (*((unsigned int *) (s+p)))));
}
//+ external count : t -> int = "caml_cursor_count"
value caml_cursor_count(value cursor) {
CAMLparam1(cursor);
int err;
db_recno_t counter;
test_cursor_closed(cursor);
err = UW_cursor(cursor)->c_count(UW_cursor(cursor), &counter,0);
if (err != 0) { raise_db(db_strerror(err)); }
CAMLreturn (Val_long(counter));
}
static void read_main_debug_info(struct debug_info *di)
{
CAMLparam0();
CAMLlocal3(events, evl, l);
char_os *exec_name;
int fd, num_events, orig, i;
struct channel *chan;
struct exec_trailer trail;
CAMLassert(di->already_read == 0);
di->already_read = 1;
if (caml_params->cds_file != NULL) {
exec_name = (char_os*) caml_params->cds_file;
} else {
exec_name = (char_os*) caml_params->exe_name;
}
fd = caml_attempt_open(&exec_name, &trail, 1);
if (fd < 0){
caml_fatal_error ("executable program file not found");
CAMLreturn0;
}
caml_read_section_descriptors(fd, &trail);
if (caml_seek_optional_section(fd, &trail, "DBUG") != -1) {
chan = caml_open_descriptor_in(fd);
num_events = caml_getword(chan);
events = caml_alloc(num_events, 0);
for (i = 0; i < num_events; i++) Op_val(events)[i] = Val_unit;
for (i = 0; i < num_events; i++) {
orig = caml_getword(chan);
evl = caml_input_val(chan);
caml_input_val(chan); /* Skip the list of absolute directory names */
/* Relocate events in event list */
for (l = evl; l != Val_int(0); l = Field_imm(l, 1)) {
value ev = Field_imm(l, 0);
Store_field (ev, EV_POS, Val_long(Long_val(Field(ev, EV_POS)) + orig));
}
/* Record event list */
Store_field(events, i, evl);
}
caml_close_channel(chan);
di->events = process_debug_events(caml_start_code, events, &di->num_events);
}
CAMLreturn0;
}
value caml_ba_get_N(value vb, value * vind, int nind)
{
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.get: 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 read */
switch ((b->flags) & CAML_BA_KIND_MASK) {
default:
Assert(0);
#ifdef _KERNEL
#else
case CAML_BA_FLOAT32:
return caml_copy_double(((float *) b->data)[offset]);
case CAML_BA_FLOAT64:
return caml_copy_double(((double *) b->data)[offset]);
#endif
case CAML_BA_SINT8:
return Val_int(((int8 *) b->data)[offset]);
case CAML_BA_UINT8:
return Val_int(((uint8 *) b->data)[offset]);
case CAML_BA_SINT16:
return Val_int(((int16 *) b->data)[offset]);
case CAML_BA_UINT16:
return Val_int(((uint16 *) b->data)[offset]);
case CAML_BA_INT32:
return caml_copy_int32(((int32 *) b->data)[offset]);
case CAML_BA_INT64:
return caml_copy_int64(((int64 *) b->data)[offset]);
case CAML_BA_NATIVE_INT:
return caml_copy_nativeint(((intnat *) b->data)[offset]);
case CAML_BA_CAML_INT:
return Val_long(((intnat *) b->data)[offset]);
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX32:
{ float * p = ((float *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
case CAML_BA_COMPLEX64:
{ double * p = ((double *) b->data) + offset * 2;
return copy_two_doubles(p[0], p[1]); }
#endif
}
}
static value alloc_process_status(HANDLE pid, int status)
{
value res, st;
st = alloc(1, 0);
Field(st, 0) = Val_int(status);
Begin_root (st);
res = alloc_small(2, 0);
Field(res, 0) = Val_long((intnat) pid);
Field(res, 1) = st;
End_roots();
return res;
}
CAMLprim value bigstring_write_stub(
value v_fd, value v_pos, value v_len, value v_bstr)
{
CAMLparam1(v_bstr);
char *bstr = get_bstr(v_bstr, v_pos);
size_t len = Long_val(v_len);
ssize_t written;
caml_enter_blocking_section();
written = write(Int_val(v_fd), bstr, len);
caml_leave_blocking_section();
if (written == -1) uerror("write", Nothing);
CAMLreturn(Val_long(written));
}
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);
}
EXTERN value compare_strings(value s1, value s2) /* ML */
{
mlsize_t len1, len2;
register mlsize_t len;
register unsigned char * p1, * p2;
len1 = string_length(s1);
len2 = string_length(s2);
for (len = (len1 <= len2 ? len1 : len2),
p1 = (unsigned char *) String_val(s1),
p2 = (unsigned char *) String_val(s2);
len > 0;
len--, p1++, p2++)
if (*p1 != *p2)
return (*p1 < *p2 ? Val_long(-1) : Val_long(1));
if (len1 == len2)
return Val_long(0);
else if (len1 < len2)
return Val_long(-2);
else
return Val_long(2);
}
CAMLexport value caml_hash_variant(char const * tag)
{
value accu;
/* Same hashing algorithm as in ../typing/btype.ml, function hash_variant */
for (accu = Val_int(0); *tag != 0; tag++)
accu = Val_int(223 * Int_val(accu) + *((unsigned char *) tag));
#ifdef ARCH_SIXTYFOUR
accu = accu & Val_long(0x7FFFFFFFL);
#endif
/* Force sign extension of bit 31 for compatibility between 32 and 64-bit
platforms */
return (int32) accu;
}
CAMLprim value result_bytes_write(struct job_bytes_write *job)
{
value result;
DWORD error = job->error_code;
if (error) {
lwt_unix_free_job(&job->job);
win32_maperr(error);
uerror("bytes_write", Nothing);
}
result = Val_long(job->result);
lwt_unix_free_job(&job->job);
return result;
}
static value re_alloc_groups(value re, value str)
{
CAMLparam1(str);
CAMLlocal1(res);
unsigned char * starttxt = (unsigned char *) String_val(str);
int n = Numgroups(re);
int i;
struct re_group * group;
res = caml_alloc(n * 2, 0);
for (i = 0; i < n; i++) {
group = &(re_group[i]);
if (group->start == NULL || group->end == NULL) {
Field(res, i * 2) = Val_int(-1);
Field(res, i * 2 + 1) = Val_int(-1);
} else {
Field(res, i * 2) = Val_long(group->start - starttxt);
Field(res, i * 2 + 1) = Val_long(group->end - starttxt);
}
}
CAMLreturn(res);
}
CAMLprim value netsys_poll_event_sources(value pav, value tmov)
{
#ifdef HAVE_POLL_AGGREG
struct poll_aggreg *pa;
int code;
int tmo;
int k;
int e;
#ifdef USABLE_EPOLL
struct epoll_event ee[EPOLL_NUM];
#endif
CAMLparam2(pav, tmov);
CAMLlocal3(r, r_item, r_cons);
tmo = Int_val(tmov);
pa = *(Poll_aggreg_val(pav));
#ifdef USABLE_EPOLL
caml_enter_blocking_section();
code = epoll_wait(pa->fd, ee, EPOLL_NUM, tmo);
e = errno;
caml_leave_blocking_section();
if (code == -1) unix_error(e, "epoll_wait", Nothing);
r = Val_int(0);
for (k=0; k<code; k++) {
if (ee[k].data.u64 == 1) { /* This is the reserved cancel_fd */
uint64_t buf;
int p;
p = read(pa->cancel_fd, (char *) &buf, 8);
}
else {
r_item = caml_alloc(3,0);
Store_field(r_item, 0, Val_long(ee[k].data.u64 >> 1));
Store_field(r_item, 1, Val_long(0)); /* i.e. mask = 0 */
Store_field(r_item, 2,
Val_int(translate_to_poll_events(ee[k].events)));
r_cons = caml_alloc(2,0);
Store_field(r_cons, 0, r_item);
Store_field(r_cons, 1, r);
r = r_cons;
}
};
#endif
CAMLreturn(r);
#else
invalid_argument("Netsys_posix.pull_event_sources not available");
#endif
}
CAMLprim value hh_counter_next(void) {
CAMLparam0();
CAMLlocal1(result);
uintptr_t v;
if (counter) {
v = __sync_fetch_and_add(counter, 1);
} else {
v = ++early_counter;
}
result = Val_long(v % Max_long); // Wrap around.
CAMLreturn(result);
}
/* Converts subject offsets from C-integers to OCaml-Integers.
This is a bit tricky, because there are 32- and 64-bit platforms around
and OCaml chooses the larger possibility for representing integers when
available (also in arrays) - not so the PCRE!
*/
static inline void copy_ovector(
long subj_start, const int *ovec_src, caml_int_ptr ovec_dst, int subgroups2)
{
if (subj_start == 0)
while (subgroups2--) {
*ovec_dst = Val_int(*ovec_src);
--ovec_src; --ovec_dst;
}
else
while (subgroups2--) {
*ovec_dst = Val_long(*ovec_src + subj_start);
--ovec_src; --ovec_dst;
}
}
CAMLprim value caml_ml_input_int(value vchannel)
{
CAMLparam1 (vchannel);
struct channel * channel = Channel(vchannel);
intnat i;
Lock(channel);
i = caml_getword(channel);
Unlock(channel);
#ifdef ARCH_SIXTYFOUR
i = (i << 32) >> 32; /* Force sign extension */
#endif
CAMLreturn (Val_long(i));
}
CAMLprim value caml_gc_get(value v)
{
CAMLparam0 (); /* v is ignored */
CAMLlocal1 (res);
res = caml_alloc_tuple (8);
Store_field (res, 0, Val_long (caml_minor_heap_wsz)); /* s */
Store_field (res, 1, Val_long (caml_major_heap_increment)); /* i */
Store_field (res, 2, Val_long (caml_percent_free)); /* o */
Store_field (res, 3, Val_long (caml_verb_gc)); /* v */
Store_field (res, 4, Val_long (caml_percent_max)); /* O */
#ifndef NATIVE_CODE
Store_field (res, 5, Val_long (caml_max_stack_size)); /* l */
#else
Store_field (res, 5, Val_long (0));
#endif
Store_field (res, 6, Val_long (caml_allocation_policy)); /* a */
Store_field (res, 7, Val_long (caml_major_window)); /* w */
CAMLreturn (res);
}