コード例 #1
0
ファイル: sendrecv.c プロジェクト: nodakai/ocaml
CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len, value flags)
{
    SOCKET s = Socket_val(sock);
    int flg = convert_flag_list(flags, msg_flag_table);
    int ret;
    intnat numbytes;
    char iobuf[UNIX_BUFFER_SIZE];
    value res;
    value adr = Val_unit;
    union sock_addr_union addr;
    socklen_param_type addr_len;
    DWORD err = 0;

    Begin_roots2 (buff, adr);
    numbytes = Long_val(len);
    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
    addr_len = sizeof(sock_addr);
    enter_blocking_section();
    ret = recvfrom(s, iobuf, (int) numbytes, flg, &addr.s_gen, &addr_len);
    if (ret == -1) err = WSAGetLastError();
    leave_blocking_section();
    if (ret == -1) {
        win32_maperr(err);
        uerror("recvfrom", Nothing);
    }
    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
    adr = alloc_sockaddr(&addr, addr_len, -1);
    res = alloc_small(2, 0);
    Field(res, 0) = Val_int(ret);
    Field(res, 1) = adr;
    End_roots();
    return res;
}
コード例 #2
0
ファイル: gmtime.c プロジェクト: Chris00/ocaml
CAMLprim value unix_mktime(value t)
{
  struct tm tm;
  time_t clock;
  value res;
  value tmval = Val_unit, clkval = Val_unit;

  Begin_roots2(tmval, clkval);
    tm.tm_sec = Int_val(Field(t, 0));
    tm.tm_min = Int_val(Field(t, 1));
    tm.tm_hour = Int_val(Field(t, 2));
    tm.tm_mday = Int_val(Field(t, 3));
    tm.tm_mon = Int_val(Field(t, 4));
    tm.tm_year = Int_val(Field(t, 5));
    tm.tm_wday = Int_val(Field(t, 6));
    tm.tm_yday = Int_val(Field(t, 7));
    tm.tm_isdst = -1; /* tm.tm_isdst = Bool_val(Field(t, 8)); */
    clock = mktime(&tm);
    if (clock == (time_t) -1) unix_error(ERANGE, "mktime", Nothing);
    tmval = alloc_tm(&tm);
    clkval = copy_double((double) clock);
    res = alloc_small(2, 0);
    Field(res, 0) = clkval;
    Field(res, 1) = tmval;
  End_roots ();
  return res;
}
コード例 #3
0
ファイル: win32.c プロジェクト: OpenXT/ocaml
CAMLprim value caml_thread_new(value clos)
{
  caml_thread_t th;
  value vthread = Val_unit;
  value descr;
  DWORD th_id;

  Begin_roots2 (clos, vthread)
    /* Create a finalized value to hold thread handle */
    vthread = alloc_final(sizeof(struct caml_thread_handle) / sizeof(value),
                          caml_thread_finalize, 1, 1000);
    ((struct caml_thread_handle *)vthread)->handle = NULL;
    /* Create a descriptor for the new thread */
    descr = alloc_tuple(sizeof(struct caml_thread_descr) / sizeof(value));
    Ident(descr) = Val_long(thread_next_ident);
    Start_closure(descr) = clos;
    Threadhandle(descr) = (struct caml_thread_handle *) vthread;
    thread_next_ident++;
    /* Create an info block for the current thread */
    th = (caml_thread_t) stat_alloc(sizeof(struct caml_thread_struct));
    th->descr = descr;
#ifdef NATIVE_CODE
    th->bottom_of_stack = NULL;
    th->exception_pointer = NULL;
    th->local_roots = NULL;
#else
    /* Allocate the stacks */
    th->stack_low = (value *) stat_alloc(Thread_stack_size);
    th->stack_high = th->stack_low + Thread_stack_size / sizeof(value);
    th->stack_threshold = th->stack_low + Stack_threshold / sizeof(value);
    th->sp = th->stack_high;
    th->trapsp = th->stack_high;
    th->local_roots = NULL;
    th->external_raise = NULL;
    th->backtrace_pos = 0;
    th->backtrace_buffer = NULL;
    th->backtrace_last_exn = Val_unit;
#endif
    /* Add thread info block to the list of threads */
    th->next = curr_thread->next;
    th->prev = curr_thread;
    curr_thread->next->prev = th;
    curr_thread->next = th;
    /* Fork the new thread */
    th->wthread =
      CreateThread(NULL, 0, caml_thread_start, (void *) th, 0, &th_id);
    if (th->wthread == NULL) {
      /* Fork failed, remove thread info block from list of threads */
      th->next->prev = curr_thread;
      curr_thread->next = th->next;
#ifndef NATIVE_CODE
      stat_free(th->stack_low);
#endif
      stat_free(th);
      caml_wthread_error("Thread.create");
    }
    ((struct caml_thread_handle *)vthread)->handle = th->wthread;
  End_roots();
  return descr;
}
コード例 #4
0
CAMLprim value unix_recvfrom(value sock, value buff, value ofs, value len,
                             value flags)
{
  int ret, cv_flags;
  long numbytes;
  char iobuf[UNIX_BUFFER_SIZE];
  value res;
  value adr = Val_unit;
  union sock_addr_union addr;
  socklen_param_type addr_len;

  cv_flags = convert_flag_list(flags, msg_flag_table);
  Begin_roots2 (buff, adr);
    numbytes = Long_val(len);
    if (numbytes > UNIX_BUFFER_SIZE) numbytes = UNIX_BUFFER_SIZE;
    addr_len = sizeof(addr);
    enter_blocking_section();
    ret = recvfrom(Int_val(sock), iobuf, (int) numbytes, cv_flags,
                   &addr.s_gen, &addr_len);
    leave_blocking_section();
    if (ret == -1) uerror("recvfrom", Nothing);
    memmove (&Byte(buff, Long_val(ofs)), iobuf, ret);
    adr = alloc_sockaddr(&addr, addr_len, -1);
    res = alloc_small(2, 0);
    Field(res, 0) = Val_int(ret);
    Field(res, 1) = adr;
  End_roots();
  return res;
}
コード例 #5
0
ファイル: windir.c プロジェクト: vouillon/ocaml
CAMLprim value win_findfirst(value name)
{
  HANDLE h;
  value v;
  WIN32_FIND_DATA fileinfo;
  value valname = Val_unit;
  value valh = Val_unit;

  caml_unix_check_path(name, "opendir");
  Begin_roots2 (valname,valh);
    h = FindFirstFile(String_val(name),&fileinfo);
    if (h == INVALID_HANDLE_VALUE) {
      DWORD err = GetLastError();
      if (err == ERROR_NO_MORE_FILES)
        raise_end_of_file();
      else {
        win32_maperr(err);
        uerror("opendir", Nothing);
      }
    }
    valname = copy_string(fileinfo.cFileName);
    valh = win_alloc_handle(h);
    v = alloc_small(2, 0);
    Field(v,0) = valname;
    Field(v,1) = valh;
  End_roots();
  return v;
}
コード例 #6
0
ファイル: blit_stubs.c プロジェクト: camlspotter/ocaml-mingw
CAMLprim value bin_prot_blit_buf_stub(
  value v_src_pos, value v_src, value v_dst_pos, value v_dst, value v_len)
{
  struct caml_ba_array *ba_src = Caml_ba_array_val(v_src);
  struct caml_ba_array *ba_dst = Caml_ba_array_val(v_dst);
  char *src = (char *) ba_src->data + Long_val(v_src_pos);
  char *dst = (char *) ba_dst->data + Long_val(v_dst_pos);
  size_t len = (size_t) Long_val(v_len);
  if
    (
      unlikely(len > 65536)
      || unlikely(((ba_src->flags & CAML_BA_MAPPED_FILE) != 0))
      || unlikely(((ba_dst->flags & CAML_BA_MAPPED_FILE) != 0))
    )
  /* use [memmove] rather than [memcpy] because src and dst may overlap */
  {
    Begin_roots2(v_src, v_dst);
    caml_enter_blocking_section();
      memmove(dst, src, len);
    caml_leave_blocking_section();
    End_roots();
  }
  else memmove(dst, src, len);
  return Val_unit;
}
コード例 #7
0
ファイル: reduction.c プロジェクト: cakeplus/OCaml-R
CAMLprim value ocamlr_eval_sxp (value sexp_list) {

  /* sexp_list is an OCaml value containing a SEXP of sexptype LANGSXP.
     This is a LISP-style pairlist of SEXP values. r_eval_sxp executes
     the whole pairlist, and sends back the resulting SEXP wrapped up in
     an OCaml value. There's also an error handling mechanism. */

  /* r_eval_sxp handles values of type LANGSXP and PROMSXP. So we have two
     functions on the OCaml side associated to this stub, the first on
     with type lang sexp -> raw sexp, the other one with type
     prom sexp -> raw sexp. This also means that there is a dynamic type
     checking being done in the scope of the R_tryEval function, and it
     would be nice to shortcut it with statically typed equivalents. */

  CAMLparam0();

  SEXP e;        // Placeholder for the result of beta-reduction.
  int error = 0; // Error catcher boolean.

  SEXP our_call = Sexp_val(sexp_list);
  caml_enter_blocking_section();
  e = R_tryEval(our_call, R_GlobalEnv, &error);
  caml_leave_blocking_section();

  /* Implements error handling from R to Objective Caml. */
  if (error) {

    value ml_error_call = Val_unit;
    value ml_error_message = Val_unit;

    Begin_roots2(ml_error_call, ml_error_message);

    ml_error_call = Val_sexp(ocamlr_error_call);
    ocamlr_error_call = NULL;      //should check for a memory leak here...
                                   //depends on GC status of prior error_call.

    ml_error_message = caml_copy_string(ocamlr_error_message);
    ocamlr_error_message = NULL;   //should check for a memory leak here...
                                   //it seems to me that a string is leaked here.

    value error_result = caml_alloc_small(2, 0);
    Store_field(error_result, 0, ml_error_call);
    Store_field(error_result, 1, ml_error_message);

    /* The exception callback mechanism is described on the webpage
       http://www.pps.jussieu.fr/Livres/ora/DA-OCAML/book-ora118.html
       We should check to see if we could avoid the string-name lookup
       to avoid unnecessary delays in exception handling. */

    caml_raise_with_arg(*caml_named_value("OCaml-R generic error"), error_result);

    End_roots();
  }

  CAMLreturn(Val_sexp(e));
}
コード例 #8
0
ファイル: getglobal.c プロジェクト: aryx/fork-efuns-old
value makeblock2(value tag, value accu,value arg1)
{
  value res;

  Begin_roots2(accu,arg1);
  res = alloc(2, Int_val(tag));
  End_roots();
  initialize(&Field(res,0), accu);
  initialize(&Field(res,1), arg1);

  return res;
}
コード例 #9
0
ファイル: st_stubs.c プロジェクト: avsm/ocaml-ppa
CAMLprim value caml_condition_wait(value wcond, value wmut)           /* ML */
{
  st_condvar cond = Condition_val(wcond);
  st_mutex mut = Mutex_val(wmut);
  st_retcode retcode;

  Begin_roots2(wcond, wmut)     /* prevent deallocation of cond and mutex */
    enter_blocking_section();
    retcode = st_condvar_wait(cond, mut);
    leave_blocking_section();
  End_roots();
  st_check_error(retcode, "Condition.wait");
  return Val_unit;
}
コード例 #10
0
ファイル: getglobal.c プロジェクト: aryx/fork-efuns-old
value makeblock(value tag, value size, value accu, value stack,value stp)
{
  int i;
  int sz = Int_val(size);
  int sp = Int_val(stp);
  value res;

  Begin_roots2(accu,stack);
  res = alloc(Int_val(size), Int_val(tag));
  End_roots();
  for(i=1;i<sz;i++) initialize(&Field(res,i),Field(stack,sp++));
  initialize(&Field(res,0), accu);

  return res;
}
コード例 #11
0
ファイル: getproto.c プロジェクト: bluddy/ocaml-multicore
static value alloc_proto_entry(struct protoent *entry)
{
  value res;
  value name = Val_unit, aliases = Val_unit;

  Begin_roots2 (name, aliases);
    name = copy_string(entry->p_name);
    aliases = copy_string_array((const char**)entry->p_aliases);
    res = alloc_small(3, 0);
    Init_field(res, 0, name);
    Init_field(res, 1, aliases);
    Init_field(res, 2, Val_int(entry->p_proto));
  End_roots();
  return res;
}
コード例 #12
0
ファイル: st_stubs.c プロジェクト: avsm/ocaml-ppa
static value caml_thread_new_descriptor(value clos)
{
  value mu = Val_unit;
  value descr;
  Begin_roots2 (clos, mu)
    /* Create and initialize the termination semaphore */
    mu = caml_threadstatus_new();
    /* Create a descriptor for the new thread */
    descr = alloc_small(3, 0);
    Ident(descr) = Val_long(thread_next_ident);
    Start_closure(descr) = clos;
    Terminated(descr) = mu;
    thread_next_ident++;
  End_roots();
  return descr;
}
コード例 #13
0
ファイル: select.c プロジェクト: OpenXT/ocaml
static value fdset_to_fdlist(value fdlist, fd_set *fdset)
{
  value l;
  value res = Val_int(0);

  Begin_roots2(l, res);
    for (l = fdlist; l != Val_int(0); l = Field(l, 1)) {
      int fd = Int_val(Field(l, 0));
      if (FD_ISSET(fd, fdset)) {
        value newres = alloc_small(2, 0);
        Field(newres, 0) = Val_int(fd);
        Field(newres, 1) = res;
        res = newres;
      }
    }
  End_roots();
  return res;
}
コード例 #14
0
ファイル: bigstring_stubs.c プロジェクト: eu90h/core_kernel
CAMLprim value bigstring_blit_stub(
  value v_src, value v_src_pos, value v_dst, value v_dst_pos, value v_len)
{
  struct caml_ba_array *ba_src = Caml_ba_array_val(v_src);
  struct caml_ba_array *ba_dst = Caml_ba_array_val(v_dst);
  char *src = (char *) ba_src->data + Long_val(v_src_pos);
  char *dst = (char *) ba_dst->data + Long_val(v_dst_pos);
  size_t len = Long_val(v_len);
  if (len > THREAD_IO_CUTOFF)
  {
    Begin_roots2(v_src, v_dst);
    caml_enter_blocking_section();
      memmove(dst, src, Long_val(v_len));
    caml_leave_blocking_section();
    End_roots();
  }
  else memmove(dst, src, Long_val(v_len));
  return Val_unit;
}
コード例 #15
0
ファイル: pipe.c プロジェクト: stedolan/ocaml
CAMLprim value unix_pipe(value unit)
{
  SECURITY_ATTRIBUTES attr;
  HANDLE readh, writeh;
  value readfd = Val_unit, writefd = Val_unit, res;

  attr.nLength = sizeof(attr);
  attr.lpSecurityDescriptor = NULL;
  attr.bInheritHandle = TRUE;
  if (! CreatePipe(&readh, &writeh, &attr, SIZEBUF)) {
    win32_maperr(GetLastError());
    uerror("pipe", Nothing);
  }
  Begin_roots2(readfd, writefd)
    readfd = win_alloc_handle(readh);
    writefd = win_alloc_handle(writeh);
    res = caml_alloc_2(0, readfd, writefd);
  End_roots();
  return res;
}
コード例 #16
0
ファイル: win32.c プロジェクト: OpenXT/ocaml
CAMLprim value caml_condition_wait(value cond, value mut)
{
  int retcode;
  HANDLE m = Mutex_val(mut);
  HANDLE s = Condition_val(cond)->sem;
  HANDLE handles[2];

  Condition_val(cond)->count ++;
  Begin_roots2(cond, mut)       /* prevent deallocation of cond and mutex */
    enter_blocking_section();
    /* Release mutex */
    ReleaseMutex(m);
    /* Wait for semaphore to be non-null, and decrement it.
       Simultaneously, re-acquire mutex. */
    handles[0] = s;
    handles[1] = m;
    retcode = WaitForMultipleObjects(2, handles, TRUE, INFINITE);
    leave_blocking_section();
  End_roots();
  if (retcode == WAIT_FAILED) caml_wthread_error("Condition.wait");
  return Val_unit;
}
コード例 #17
0
ファイル: pcre_stubs.c プロジェクト: DMClambo/pfff
/* Executes a pattern match with runtime options, a regular expression, a
   string offset, a string length, a subject string, a number of subgroup
   offsets, an offset vector and an optional callout function */
CAMLprim value pcre_exec_stub(value v_opt, value v_rex, value v_ofs,
                              value v_subj, value v_subgroups2, value v_ovec,
                              value v_maybe_cof)
{
  const int ofs = Int_val(v_ofs), len = caml_string_length(v_subj);

  if (ofs > len || ofs < 0)
    caml_invalid_argument("Pcre.pcre_exec_stub: illegal offset");

  {
    const pcre *code = (pcre *) Field(v_rex, 1);  /* Compiled pattern */
    const pcre_extra *extra = (pcre_extra *) Field(v_rex, 2);  /* Extra info */
    const char *ocaml_subj = String_val(v_subj);  /* Subject string */
    const int opt = Int_val(v_opt);  /* Runtime options */
    int subgroups2 = Int_val(v_subgroups2);
    const int subgroups2_1 = subgroups2 - 1;
    const int subgroups3 = (subgroups2 >> 1) + subgroups2;

    /* Special case when no callout functions specified */
    if (v_maybe_cof == None) {
      int *ovec = (int *) &Field(v_ovec, 0);

      /* Performs the match */
      const int ret =
        pcre_exec(code, extra, ocaml_subj, len, ofs, opt, ovec, subgroups3);

      if (ret < 0) {
        switch(ret) {
          case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
          case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
          case PCRE_ERROR_MATCHLIMIT :
            caml_raise_constant(*pcre_exc_MatchLimit);
          case PCRE_ERROR_BADPARTIAL :
            caml_raise_constant(*pcre_exc_BadPartial);
          case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
          case PCRE_ERROR_BADUTF8_OFFSET :
            caml_raise_constant(*pcre_exc_BadUTF8Offset);
          default :
            caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
        }
      }

      else {
        const int *ovec_src = ovec + subgroups2_1;
        long int *ovec_dst = (long int *) ovec + subgroups2_1;

        /* Converts 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 */
        while (subgroups2--) {
          *ovec_dst = Val_int(*ovec_src);
          --ovec_src; --ovec_dst;
        }
      }
    }

    /* There are callout functions */
    else {
      value v_cof = Field(v_maybe_cof, 0);
      value v_substrings;
      char *subj = caml_stat_alloc(sizeof(char) * len);
      int *ovec = caml_stat_alloc(sizeof(int) * subgroups3);
      int ret;
      struct cod cod = { (value *) NULL, (value *) NULL, (value) NULL };
      struct pcre_extra new_extra =
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL, 0 };
#else
        { PCRE_EXTRA_CALLOUT_DATA, NULL, 0, NULL, NULL };
#endif

      memcpy(subj, ocaml_subj, len);

      Begin_roots3(v_rex, v_cof, v_substrings);
        Begin_roots2(v_subj, v_ovec);
          v_substrings = caml_alloc_small(2, 0);
        End_roots();

        Field(v_substrings, 0) = v_subj;
        Field(v_substrings, 1) = v_ovec;

        cod.v_substrings_p = &v_substrings;
        cod.v_cof_p = &v_cof;
        new_extra.callout_data = &cod;

        if (extra == NULL) {
          ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
                          subgroups3);
        }
        else {
          new_extra.flags = PCRE_EXTRA_CALLOUT_DATA | extra->flags;
          new_extra.study_data = extra->study_data;
          new_extra.match_limit = extra->match_limit;
          new_extra.tables = extra->tables;
#ifdef PCRE_CONFIG_MATCH_LIMIT_RECURSION
          new_extra.match_limit_recursion = extra->match_limit_recursion;
#endif

          ret = pcre_exec(code, &new_extra, subj, len, ofs, opt, ovec,
                          subgroups3);
        }

        free(subj);
      End_roots();

      if (ret < 0) {
        free(ovec);
        switch(ret) {
          case PCRE_ERROR_NOMATCH : caml_raise_constant(*pcre_exc_Not_found);
          case PCRE_ERROR_PARTIAL : caml_raise_constant(*pcre_exc_Partial);
          case PCRE_ERROR_MATCHLIMIT :
            caml_raise_constant(*pcre_exc_MatchLimit);
          case PCRE_ERROR_BADPARTIAL :
            caml_raise_constant(*pcre_exc_BadPartial);
          case PCRE_ERROR_BADUTF8 : caml_raise_constant(*pcre_exc_BadUTF8);
          case PCRE_ERROR_BADUTF8_OFFSET :
            caml_raise_constant(*pcre_exc_BadUTF8Offset);
          case PCRE_ERROR_CALLOUT : caml_raise(cod.v_exn);
          default :
            caml_raise_with_string(*pcre_exc_InternalError, "pcre_exec_stub");
        }
      }

      else {
        int *ovec_src = ovec + subgroups2_1;
        long int *ovec_dst = &Field(v_ovec, 0) + subgroups2_1;

        while (subgroups2--) {
          *ovec_dst = Val_int(*ovec_src);
          --ovec_src; --ovec_dst;
        }

        free(ovec);
      }
    }
  }

  return Val_unit;
}

/* Byte-code hook for pcre_exec_stub
   Needed, because there are more than 5 arguments */
CAMLprim value pcre_exec_stub_bc(value *argv, int __unused argn)
{
  return pcre_exec_stub(argv[0], argv[1], argv[2], argv[3],
                        argv[4], argv[5], argv[6]);
}

/* Generates a new set of chartables for the current locale (see man
   page of PCRE */
CAMLprim value pcre_maketables_stub(value __unused v_unit)
{
  /* GC will do a full cycle every 100 table set allocations
     (one table set consumes 864 bytes -> maximum of 86400 bytes
     unreclaimed table sets) */
  const value v_res = caml_alloc_final(2, pcre_dealloc_tables, 864, 86400);
  Field(v_res, 1) = (value) pcre_maketables();
  return v_res;
}

/* Wraps around the isspace-function */
CAMLprim value pcre_isspace_stub(value v_c)
{
  return Val_bool(isspace(Int_val(v_c)));
}

/* Returns number of substring associated with a name */
CAMLprim value pcre_get_stringnumber_stub(value v_rex, value v_name)
{
  const int ret = pcre_get_stringnumber((pcre *) Field(v_rex, 1),
                                        String_val(v_name));
  if (ret == PCRE_ERROR_NOSUBSTRING)
    caml_invalid_argument("Named string not found");

  return Val_int(ret);
}

/* Returns array of names of named substrings in a regexp */
CAMLprim value pcre_names_stub(value v_rex)
{
  CAMLparam0();
  CAMLlocal1(v_res);
  int name_count;
  int entry_size;
  const char *tbl_ptr;
  int i;

  int ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMECOUNT, &name_count);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMEENTRYSIZE, &entry_size);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  ret = pcre_fullinfo_stub(v_rex, PCRE_INFO_NAMETABLE, &tbl_ptr);
  if (ret != 0)
    caml_raise_with_string(*pcre_exc_InternalError, "pcre_names_stub");

  v_res = caml_alloc(name_count, 0);

  for (i = 0; i < name_count; ++i) {
    value v_name = caml_copy_string(tbl_ptr + 2);
    Store_field(v_res, i, v_name);
    tbl_ptr += entry_size;
  }

  CAMLreturn(v_res);
}
コード例 #18
-1
ファイル: dump_img.c プロジェクト: avsm/ocaml-ppa
value caml_gr_dump_image(value image)
{
  int width, height, i, j;
  XImage * idata, * imask;
  value m = Val_unit;

  Begin_roots2(image, m);
    caml_gr_check_open();
    width = Width_im(image);
    height = Height_im(image);
    m = alloc(height, 0);
    for (i = 0; i < height; i++) {
      value v = alloc(width, 0);
      modify(&Field(m, i), v);
    }

    idata =
      XGetImage(caml_gr_display, Data_im(image), 0, 0, width, height, (-1), ZPixmap);
    for (i = 0; i < height; i++)
      for (j = 0; j < width; j++)
        Field(Field(m, i), j) = Val_int(caml_gr_rgb_pixel(XGetPixel(idata, j, i)));
    XDestroyImage(idata);

    if (Mask_im(image) != None) {
      imask =
        XGetImage(caml_gr_display, Mask_im(image), 0, 0, width, height, 1, ZPixmap);
      for (i = 0; i < height; i++)
        for (j = 0; j < width; j++)
          if (XGetPixel(imask, j, i) == 0)
            Field(Field(m, i), j) = Val_int(Transparent);
      XDestroyImage(imask);
    }
  End_roots();
  return m;
}