Пример #1
0
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);
}
Пример #2
0
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));
}
Пример #3
0
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);
}
Пример #4
0
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));
}
Пример #5
0
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);
}
Пример #6
0
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));
}
Пример #7
0
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;
}
Пример #8
0
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"));
}
Пример #9
0
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);
}
Пример #10
0
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);
}
Пример #11
0
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));
}
Пример #12
0
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));
}
Пример #13
0
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);
}
Пример #14
0
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);
}
Пример #15
0
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)))));
}
Пример #16
0
//+   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));
}
Пример #17
0
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;
}
Пример #18
0
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
  }
}
Пример #19
0
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;
}
Пример #20
0
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));
}
Пример #21
0
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);
}
Пример #22
0
Файл: str.c Проект: Athas/mosml
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);
}
Пример #23
0
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;
}
Пример #24
0
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;
}
Пример #25
0
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);
}
Пример #26
0
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
}
Пример #27
0
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);
}
Пример #28
0
/* 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;
    }
}
Пример #29
0
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));
}
Пример #30
0
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);
}