value mlptrace_peekregisters (value pid_v) { pid_t pid; struct user usreg; long l = 0; int savederrno = errno; CAMLparam1 (pid_v); CAMLlocal5 (res_v, eip_v, eax_v, ebx_v, ecx_v); CAMLlocal5 (edx_v, esi_v, edi_v, ebp_v, esp_v); CAMLlocal2 (eflags_v, origeax_v); pid = Long_val (pid_v); memset (&usreg, 0, sizeof (usreg)); #ifndef NO_BLOCKING_SECTION caml_enter_blocking_section (); #endif l = ptrace (PTRACE_GETREGS, pid, (void *) 0, &usreg); #ifndef NO_BLOCKING_SECTION caml_leave_blocking_section (); #endif if (l == -1 && errno) uerror ("Ptrace.peekregisters", Nothing); if (savederrno) errno = savederrno; eip_v = caml_copy_nativeint (usreg.regs.eip); eax_v = caml_copy_nativeint (usreg.regs.eax); ebx_v = caml_copy_nativeint (usreg.regs.ebx); ecx_v = caml_copy_nativeint (usreg.regs.ecx); edx_v = caml_copy_nativeint (usreg.regs.edx); esi_v = caml_copy_nativeint (usreg.regs.esi); edi_v = caml_copy_nativeint (usreg.regs.edi); ebp_v = caml_copy_nativeint (usreg.regs.ebp); esp_v = caml_copy_nativeint (usreg.regs.esp); eflags_v = caml_copy_nativeint (usreg.regs.eflags); origeax_v = caml_copy_nativeint (usreg.regs.orig_eax); res_v = alloc_small (0, 11); Field (res_v, 0) = eip_v; Field (res_v, 1) = eax_v; Field (res_v, 2) = ebx_v; Field (res_v, 3) = ecx_v; Field (res_v, 4) = edx_v; Field (res_v, 5) = esi_v; Field (res_v, 6) = edi_v; Field (res_v, 7) = ebp_v; Field (res_v, 8) = esp_v; Field (res_v, 9) = eflags_v; Field (res_v, 10) = origeax_v; CAMLreturn (res_v); }
herr_t hdf5_h5l_operator(hid_t group, const char *name, const H5L_info_t *info, void *op_data) { CAMLparam0(); CAMLlocal5(ret, info_v, address_v, args0, args1); CAMLlocal2(args2, args3); value args[4]; struct operator_data *operator_data = op_data; args0 = alloc_h5l(group); args1 = caml_copy_string(name); args2 = Val_h5l_info(info); args3 = *operator_data->operator_data; args[0] = args0; args[1] = args1; args[2] = args2; args[3] = args3; ret = caml_callbackN_exn(*operator_data->callback, 4, args); if (Is_exception_result(ret)) { *(operator_data->exception) = Extract_exception(ret); return -1; } CAMLreturnT(herr_t, H5_iter_val(ret)); }
static value stat_aux(int use_64, struct stat *buf) { CAMLparam0(); CAMLlocal5(atime, mtime, ctime, offset, v); #include "nanosecond_stat.h" atime = caml_copy_double((double) buf->st_atime + (NSEC(buf, a) / 1000000000.0)); mtime = caml_copy_double((double) buf->st_mtime + (NSEC(buf, m) / 1000000000.0)); ctime = caml_copy_double((double) buf->st_ctime + (NSEC(buf, c) / 1000000000.0)); #undef NSEC offset = use_64 ? Val_file_offset(buf->st_size) : Val_int (buf->st_size); v = alloc_small(12, 0); Init_field(v, 0, Val_int (buf->st_dev)); Init_field(v, 1, Val_int (buf->st_ino)); Init_field(v, 2, cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, sizeof(file_kind_table) / sizeof(int), 0)); Init_field(v, 3, Val_int (buf->st_mode & 07777)); Init_field(v, 4, Val_int (buf->st_nlink)); Init_field(v, 5, Val_int (buf->st_uid)); Init_field(v, 6, Val_int (buf->st_gid)); Init_field(v, 7, Val_int (buf->st_rdev)); Init_field(v, 8, offset); Init_field(v, 9, atime); Init_field(v, 10, mtime); Init_field(v, 11, ctime); CAMLreturn(v); }
CAMLprim value caml_get_exception_backtrace(value unit) { CAMLparam0(); CAMLlocal5(events, res, arr, p, fname); int i; struct loc_info li; events = read_debug_info(); if (events == Val_false) { res = Val_int(0); /* None */ } else { arr = caml_alloc(caml_backtrace_pos, 0); for (i = 0; i < caml_backtrace_pos; i++) { extract_location_info(events, caml_backtrace_buffer[i], &li); if (li.loc_valid) { fname = caml_copy_string(li.loc_filename); p = caml_alloc_small(5, 0); Field(p, 0) = Val_bool(li.loc_is_raise); Field(p, 1) = fname; Field(p, 2) = Val_int(li.loc_lnum); Field(p, 3) = Val_int(li.loc_startchr); Field(p, 4) = Val_int(li.loc_endchr); } else { p = caml_alloc_small(1, 1); Field(p, 0) = Val_bool(li.loc_is_raise); } caml_modify(&Field(arr, i), p); } res = caml_alloc_small(1, 0); Field(res, 0) = arr; /* Some */ } CAMLreturn(res); }
static value stat_aux(/*int use_64,*/ struct stat *buf) { CAMLparam0(); CAMLlocal5(atime, mtime, ctime, offset, v); atime = caml_copy_double((double) buf->st_atime); mtime = caml_copy_double((double) buf->st_mtime); ctime = caml_copy_double((double) buf->st_ctime); offset = /*use_64 ? Val_file_offset(buf->st_size) :*/ Val_int (buf->st_size); v = caml_alloc_small(12, 0); Field (v, 0) = Val_int (buf->st_dev); Field (v, 1) = Val_int (buf->st_ino); Field (v, 2) = cst_to_constr(buf->st_mode & S_IFMT, file_kind_table, sizeof(file_kind_table) / sizeof(int), 0); Field (v, 3) = Val_int (buf->st_mode & 07777); Field (v, 4) = Val_int (buf->st_nlink); Field (v, 5) = Val_int (buf->st_uid); Field (v, 6) = Val_int (buf->st_gid); Field (v, 7) = Val_int (buf->st_rdev); Field (v, 8) = offset; Field (v, 9) = atime; Field (v, 10) = mtime; Field (v, 11) = ctime; CAMLreturn(v); }
CAMLprim value ml_skin_init (value use_vbo_v, value geom_v) { CAMLparam2 (use_vbo_v, geom_v); CAMLlocal5 (vertexa_v, normala_v, uva_v, skin_v, colors_v); State *s = &glob_state; use_vbo = Bool_val (use_vbo_v); #ifdef _WIN32 if (use_vbo) { GETPA (BindBuffer); GETPA (GenBuffers); GETPA (BufferData); GETPA (BufferSubData); GETPA (MapBuffer); GETPA (UnmapBuffer); } #endif vertexa_v = Field (geom_v, 0); normala_v = Field (geom_v, 1); uva_v = Field (geom_v, 2); skin_v = Field (geom_v, 3); colors_v = Field (geom_v, 4); skin_init (s, vertexa_v, normala_v, uva_v, skin_v, colors_v); CAMLreturn (Val_unit); }
static value convert_json_t (json_t *val, int level) { CAMLparam0 (); CAMLlocal5 (rv, v, tv, sv, consv); if (level > 20) caml_invalid_argument ("too many levels of object/array nesting"); if (json_is_object (val)) { const char *key; json_t *jvalue; rv = caml_alloc (1, JSON_DICT_TAG); v = Val_int (0); /* This will create the OCaml list backwards, but JSON * dictionaries are supposed to be unordered so that shouldn't * matter, right? Well except that for some consumers this does * matter (eg. simplestreams which incorrectly uses a dict when it * really should use an array). */ json_object_foreach (val, key, jvalue) { tv = caml_alloc_tuple (2); sv = caml_copy_string (key); Store_field (tv, 0, sv); sv = convert_json_t (jvalue, level + 1); Store_field (tv, 1, sv); consv = caml_alloc (2, 0); Store_field (consv, 1, v); Store_field (consv, 0, tv); v = consv; } Store_field (rv, 0, v); }
static void event_callback_wrapper_locked (guestfs_h *g, void *data, uint64_t event, int event_handle, int flags, const char *buf, size_t buf_len, const uint64_t *array, size_t array_len) { CAMLparam0 (); CAMLlocal5 (gv, evv, ehv, bufv, arrayv); CAMLlocal2 (rv, v); value *root; size_t i; root = guestfs_get_private (g, "_ocaml_g"); gv = *root; /* Only one bit should be set in 'event'. Which one? */ evv = Val_int (event_bitmask_to_event (event)); ehv = Val_int (event_handle); bufv = caml_alloc_string (buf_len); memcpy (String_val (bufv), buf, buf_len); arrayv = caml_alloc (array_len, 0); for (i = 0; i < array_len; ++i) { v = caml_copy_int64 (array[i]); Store_field (arrayv, i, v); } value args[5] = { gv, evv, ehv, bufv, arrayv }; rv = caml_callbackN_exn (*(value*)data, 5, args); /* Callbacks shouldn't throw exceptions. There's not much we can do * except to print it. */ if (Is_exception_result (rv)) fprintf (stderr, "libguestfs: uncaught OCaml exception in event callback: %s", caml_format_exception (Extract_exception (rv))); CAMLreturn0; }
value stub_if_getaddr(value unit) { CAMLparam0(); CAMLlocal5(result, temp, name, addrstr, netmaskstr); CAMLlocal1(tuple); int ret; struct ifaddrs *ifaddrs, *tmp; struct sockaddr *sock, *netmask; result = temp = Val_emptylist; name = addrstr = Val_int(0); ret = getifaddrs(&ifaddrs); if (ret < 0) caml_failwith("cannot get interface address"); for (tmp = ifaddrs; tmp; tmp = tmp->ifa_next) { sock = tmp->ifa_addr; netmask = tmp->ifa_netmask; if (sock->sa_family == AF_INET || sock->sa_family == AF_INET6) { name = caml_copy_string(tmp->ifa_name); addrstr = alloc_addr(sock); netmaskstr = alloc_addr(netmask); tuple = caml_alloc_tuple(4); Store_field(tuple, 0, name); Store_field(tuple, 1, addrstr); Store_field(tuple, 2, netmaskstr); Store_field(tuple, 3, Val_bool(sock->sa_family == AF_INET6)); result = caml_alloc_small(2, Tag_cons); Field(result, 0) = tuple; Field(result, 1) = temp; temp = result; } } freeifaddrs(ifaddrs); CAMLreturn(result); }
static int visitor_function_wrapper (const char *dir, const char *filename, const struct guestfs_statns *stat, const struct guestfs_xattr_list *xattrs, void *opaque) { CAMLparam0 (); CAMLlocal5 (dirv, filenamev, statv, xattrsv, v); struct visitor_function_wrapper_args *args = opaque; assert (dir != NULL); assert (stat != NULL); assert (xattrs != NULL); assert (args != NULL); dirv = caml_copy_string (dir); if (filename == NULL) filenamev = Val_int (0); /* None */ else { filenamev = caml_alloc (1, 0); v = caml_copy_string (filename); Store_field (filenamev, 0, v); } statv = copy_statns (stat); xattrsv = copy_xattr_list (xattrs); /* Call the visitor_function. */ value argsv[4] = { dirv, filenamev, statv, xattrsv }; v = caml_callbackN_exn (*args->fvp, 4, argsv); if (Is_exception_result (v)) { /* The visitor_function raised an exception. Store the exception * in the 'exn' field on the stack of guestfs_int_mllib_visit, and * return an error. */ *args->exnp = Extract_exception (v); return -1; } /* No error, return normally. */ CAMLreturnT (int, 0); }
CAMLprim value lightsource_process(value record_lightsource, value list_polygon_objects, value polygon_view) { CAMLparam3(record_lightsource, list_polygon_objects, polygon_view); CAMLlocal5(polygon_prev_head, list_polygon_head, vector_prev_head, list_vector_head, tmp_polygon); CAMLlocal1(tmp_vector); LightSource l = LightSource(Vector_val(Field(record_lightsource, 0)), Double_val(Field(record_lightsource, 1)), Double_val(Field(record_lightsource, 2))); std::vector<Polygon> tmp_polygon_list = std::vector<Polygon>(); polygon_list_to_std_vector(list_polygon_objects, &tmp_polygon_list); std::vector<Vector> tmp_vector_list = std::vector<Vector>(); vector_list_to_std_vector(Field(polygon_view, 0), &tmp_vector_list); Polygon polygon = Polygon(tmp_vector_list); // auto start = std::chrono::steady_clock::now(); std::vector<Polygon> list_polygon = l.process(tmp_polygon_list); // auto duration = std::chrono::duration_cast<std::chrono::milliseconds>( // std::chrono::steady_clock::now() - start); // printf("--> %lld\n", duration.count()); polygon_prev_head = Val_unit; for (Polygon p : list_polygon) { vector_prev_head = Val_unit; for (Vector v : p.get_vertices()) { tmp_vector = caml_alloc_small(2, Double_array_tag); Double_field(tmp_vector, 0) = v.x; Double_field(tmp_vector, 1) = v.y; list_vector_head = caml_alloc_small(2, 0); Field(list_vector_head, 0) = tmp_vector; Field(list_vector_head, 1) = vector_prev_head; vector_prev_head = list_vector_head; } tmp_polygon = caml_alloc_small(1, 0); Field(tmp_polygon, 0) = list_vector_head; list_polygon_head = caml_alloc_small(2, 0); Field(list_polygon_head, 0) = tmp_polygon; Field(list_polygon_head, 1) = polygon_prev_head; polygon_prev_head = list_polygon_head; } CAMLreturn(list_polygon_head); }
SRes ml_sevenzip_read(void *object, void **buffer, size_t *size) { CFileInStream *archive_in = (CFileInStream *) object; CAMLparam0 (); CAMLlocal5 (readable, read, tuple, ml_string, ml_size); readable = archive_in->readable; read = Field(readable, 0); tuple = caml_callback(read, Val_int(*size)); ml_string = Field(tuple, 0); ml_size = Field(tuple, 1); *buffer = String_val(ml_string); *size = Int_val(ml_size); /* The GC might have moved the readable pointer */ archive_in->readable = readable; CAMLreturnT(SRes, SZ_OK); }
static value alloc_sevenzip_entry(CSzArEx db, int i) { CSzFileItem *f = db.db.Files + i; CAMLparam0 (); CAMLlocal5 (entry, index, name, size, is_directory); entry = caml_alloc (4, 0); index = Val_int(i); name = caml_copy_string(f->Name); size = Val_int(f->Size); is_directory = Val_bool(f->IsDir); Store_field (entry, 0, index); Store_field (entry, 1, name); Store_field (entry, 2, size); Store_field (entry, 3, is_directory); CAMLreturn (entry); }
CAMLprim value caml_context_split_r(CAML_R, value thread_no_as_value, value function) { #if defined(HAS_MULTICONTEXT) //&& defined(NATIVE_CODE) //DUMPROOTS("splitting: before GC-protecting locals"); CAMLparam1(function); //CAMLlocal2(result, open_channels); CAMLlocal5(result, open_channels, res, tail, chan); //DUMPROOTS("splitting: after GC-protecting locals"); int can_split = caml_can_split_r(ctx); if (! can_split) caml_raise_cannot_split_r(ctx); int thread_no = Int_val(thread_no_as_value); caml_global_context **new_contexts = caml_stat_alloc(sizeof(caml_global_context*) * thread_no); char *blob; sem_t semaphore; int i; caml_initialize_semaphore(&semaphore, 0); /* CAMLparam0(); CAMLlocal1(open_channels); */ /* Make sure that the currently-existing channels stay alive until after deserialization; we can't keep reference counts within the blob, so we pin all alive channels by keeping this list alive: */ /* //if(0){//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ /* struct channel *channel; */ /* struct channel **channels; */ /* int channel_no = 0; */ /* caml_acquire_global_lock(); */ /* for (channel = caml_all_opened_channels; */ /* channel != NULL; */ /* channel = channel->next) */ /* channel_no ++; */ /* channels = caml_stat_alloc(sizeof(struct channel*) * channel_no); */ /* for (i = 0, channel = caml_all_opened_channels; */ /* channel != NULL; */ /* i ++, channel = channel->next){ */ /* channels[i] = channel; */ /* DUMP("split-pinning channel %p, with fd %i, refcount %i->%i", channel, (int)channel->fd, channel->refcount, channel->refcount + 1); */ /* channel->refcount ++; */ /* } */ /* caml_release_global_lock(); */ //open_channels = caml_ml_all_channels_list_r(ctx); // !!!!!!!!!!!!!!!!!!!! This can occasionally cause crashes related to channel picounts. I certainly messed up something in io.c. //!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! //}//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! /* //EXPERIMENTAL: BEGIN */ /* { */ /* struct channel * channel; */ /* res = Val_emptylist; */ /* caml_acquire_global_lock(); */ /* int ii, channel_index; */ /* for(ii = 0; ii < 100; ii ++){ // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ /* for (channel_index = 0, channel = caml_all_opened_channels; */ /* channel != NULL; */ /* channel = channel->next, channel_index ++) */ /* /\* Testing channel->fd >= 0 looks unnecessary, as */ /* caml_ml_close_channel changes max when setting fd to -1. *\/ */ /* { */ /* DUMP("round %i, channel_index %i", ii, channel_index); */ /* // !!!!!!!!!!!!! BEGIN */ /* /\* chan = *\/ caml_alloc_channel_r (ctx, channel); */ /* // !!!!!!!!!!!!! END */ /* chan = Val_unit;//caml_alloc_channel_r (ctx, channel); // !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ /* tail = res; */ /* res = caml_alloc_small_r (ctx, 2, 0); */ /* Field (res, 0) = chan; */ /* Field (res, 1) = tail; */ /* } */ /* DUMP("End of round %i: there are %i channels alive", ii, channel_index); */ /* DUMP("Before GC'ing"); */ /* caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@@ */ /* DUMP("After GC'ing"); */ /* } */ /* caml_release_global_lock(); */ /* //open_channels = Val_unit/\* res *\/; */ /* open_channels = res; */ /* } */ /* //EXPERIMENTAL: END */ /* Serialize the context in the main thread, then create threads, and in each one of them deserialize it back in parallel: */ blob = caml_serialize_context(ctx, function); //if(0){//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! caml_split_and_wait_r(ctx, blob, new_contexts, thread_no, &semaphore); //}//!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! /* Now we're done with the blob: */ DUMP("destroying the blob"); caml_stat_free(blob); // !!!!!!!!!!!!!!!!!!!!!!!!!!! This is needed !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! DUMP("GC'ing after destroying the blob"); caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@@ DUMP("finalizing the semaphore"); caml_finalize_semaphore(&semaphore); /* Copy the contexts we got, and we're done with new_contexts as well: */ DUMP("copying the new context (descriptors) into the Caml data structure result"); result = caml_alloc_r(ctx, thread_no, 0); caml_gc_compaction_r(ctx, Val_unit); //!!!!!@@@@@@@@@@@@ for(i = 0; i < thread_no; i ++) caml_initialize_r(ctx, &Field(result, i), caml_value_of_context_descriptor(new_contexts[i]->descriptor)); caml_stat_free(new_contexts); DUMP("destroyed the malloced buffer of pointers new_contexts"); //DUMPROOTS("from parent, after splitting"); /* caml_acquire_global_lock(); */ /* for (i = 0; i < channel_no; i ++){ */ /* DUMP("split-unpinning channels[i] %p, with fd %i, refcount %i->%i", channels[i], (int)channels[i]->fd, channels[i]->refcount, channels[i]->refcount - 1); */ /* channels[i]->refcount --; */ /* } */ /* caml_release_global_lock(); */ CAMLreturn(result); //CAMLreturn(Val_unit); #else caml_raise_unimplemented_r(ctx); return Val_unit; // unreachable #endif // #if defined(HAS_MULTICONTEXT) //&& defined(NATIVE_CODE) }
CAMLprim value netcgi2_apache_request_finfo (value rv) { CAMLparam1 (rv); request_rec *r = Request_rec_val (rv); CAMLlocal5 (v, sb, atime, mtime, ctime); #if APACHE2 if (r->finfo.filetype != APR_NOFILE) /* Some statbuf */ { atime = (r->finfo.valid & APR_FINFO_ATIME) ? copy_double ((double) apr_time_sec (r->finfo.atime)) : copy_double (0.); mtime = (r->finfo.valid & APR_FINFO_MTIME) ? copy_double ((double) apr_time_sec (r->finfo.mtime)) : copy_double (0.); ctime = (r->finfo.valid & APR_FINFO_CTIME) ? copy_double ((double) apr_time_sec (r->finfo.ctime)) : copy_double (0.); sb = alloc_small (12, 0); Field (sb, 0) = Val_int (r->finfo.device); Field (sb, 1) = Val_int (r->finfo.inode); Field (sb, 2) = cst_to_constr (r->finfo.filetype, file_kind_table, sizeof (file_kind_table) / sizeof (int), 0); Field (sb, 3) = Val_int (r->finfo.protection); Field (sb, 4) = Val_int (r->finfo.nlink); Field (sb, 5) = Val_int (r->finfo.user); Field (sb, 6) = Val_int (r->finfo.group); Field (sb, 7) = Val_int (0); /* FIXME rdev? */ Field (sb, 8) = Val_int (r->finfo.size); /* FIXME 64 bit file offsets */ Field (sb, 9) = atime; Field (sb, 10) = mtime; Field (sb, 11) = ctime; v = alloc (1, 0); /* The "Some" block. */ Field (v, 0) = sb; } else v = Val_int (0); /* None. */ #else /* not APACHE2 */ if (r->finfo.st_mode) /* Some statbuf */ { /* This code copied and modified from otherlibs/unix/stat.c. */ atime = copy_double ((double) r->finfo.st_atime); mtime = copy_double ((double) r->finfo.st_mtime); ctime = copy_double ((double) r->finfo.st_ctime); sb = alloc_small (12, 0); Field (sb, 0) = Val_int (r->finfo.st_dev); Field (sb, 1) = Val_int (r->finfo.st_ino); Field (sb, 2) = cst_to_constr (r->finfo.st_mode & S_IFMT, file_kind_table, sizeof (file_kind_table) / sizeof (int), 0); Field (sb, 3) = Val_int (r->finfo.st_mode & 07777); Field (sb, 4) = Val_int (r->finfo.st_nlink); Field (sb, 5) = Val_int (r->finfo.st_uid); Field (sb, 6) = Val_int (r->finfo.st_gid); Field (sb, 7) = Val_int (r->finfo.st_rdev); Field (sb, 8) = Val_int (r->finfo.st_size); /* FIXME: 64 bit file offsets */ Field (sb, 9) = atime; Field (sb, 10) = mtime; Field (sb, 11) = ctime; v = alloc (1, 0); /* The "Some" block. */ Field (v, 0) = sb; } else v = Val_int (0); /* None. */ #endif /* not APACHE2 */ CAMLreturn (v); }
CAMLprim value caml_extunix_recvmsg2(value vfd, value vbuf, value ofs, value vlen, value vflags) { CAMLparam4(vfd, vbuf, ofs, vlen); CAMLlocal5(vres, vlist, v, vx, vsaddr); union { struct cmsghdr hdr; char buf[CMSG_SPACE(sizeof(int)) /* File descriptor passing */ #ifdef EXTUNIX_HAVE_IP_RECVIF + CMSG_SPACE(sizeof(struct sockaddr_dl)) /* IP_RECVIF */ #endif #ifdef EXTUNIX_HAVE_IP_RECVDSTADDR + CMSG_SPACE(sizeof(struct in_addr)) /* IP_RECVDSTADDR */ #endif ]; } cmsgbuf; struct iovec iov; struct msghdr msg; struct cmsghdr *cmsg; ssize_t n; size_t len; char iobuf[UNIX_BUFFER_SIZE]; struct sockaddr_storage ss; int sendflags; #ifdef EXTUNIX_HAVE_IP_RECVIF struct sockaddr_dl *dst = NULL; #endif len = Long_val(vlen); memset(&iov, 0, sizeof(iov)); memset(&msg, 0, sizeof(msg)); if (len > UNIX_BUFFER_SIZE) len = UNIX_BUFFER_SIZE; iov.iov_base = iobuf; iov.iov_len = len; msg.msg_name = &ss; msg.msg_namelen = sizeof(ss); msg.msg_iov = &iov; msg.msg_iovlen = 1; msg.msg_control = &cmsgbuf.buf; msg.msg_controllen = sizeof(cmsgbuf.buf); sendflags = caml_convert_flag_list(vflags, msg_flag_table); caml_enter_blocking_section(); n = recvmsg(Int_val(vfd), &msg, sendflags); caml_leave_blocking_section(); vres = caml_alloc_small(4, 0); if (n == -1) { uerror("recvmsg", Nothing); CAMLreturn (vres); } vsaddr = my_alloc_sockaddr(&ss); memmove(&Byte(vbuf, Long_val(ofs)), iobuf, n); vlist = Val_int(0); /* Build the variant list vlist */ for (cmsg = CMSG_FIRSTHDR(&msg); cmsg != NULL; cmsg = CMSG_NXTHDR(&msg, cmsg)) { if (cmsg->cmsg_level == SOL_SOCKET && cmsg->cmsg_type == SCM_RIGHTS) { /* CMSG_DATA is aligned, so the following is cool */ v = caml_alloc_small(2, TAG_FILEDESCRIPTOR); Field(v, 0) = Val_int(*(int *)CMSG_DATA(cmsg)); Field(v, 1) = vlist; vlist = v; continue; } #ifdef EXTUNIX_HAVE_IP_RECVIF if (cmsg->cmsg_level == IPPROTO_IP && cmsg->cmsg_type == IP_RECVIF) { dst = (struct sockaddr_dl *)CMSG_DATA(cmsg); v = caml_alloc_small(2, 0); vx = caml_alloc_small(1, TAG_IP_RECVIF); Field(vx, 0) = Val_int(dst->sdl_index); Field(v, 0) = vx; Field(v, 1) = vlist; vlist = v; continue; } #endif #ifdef EXTUNIX_HAVE_IP_RECVDSTADDR if (cmsg->cmsg_level == IPPROTO_IP && cmsg->cmsg_type == IP_RECVDSTADDR) { struct in_addr ipdst; ipdst = *(struct in_addr *)CMSG_DATA(cmsg); v = caml_alloc_small(2, 0); vx = caml_alloc_small(1, TAG_IP_RECVDSTADDR); Field(vx, 0) = caml_alloc_string(4); memcpy(String_val(Field(vx, 0)), &ipdst, 4); Field(v, 0) = vx; Field(v, 1) = vlist; vlist = v; continue; } #endif } /* Now build the result */ Field(vres, 0) = Val_long(n); Field(vres, 1) = vsaddr; Field(vres, 2) = vlist; Field(vres, 3) = int_to_recvflags(msg.msg_flags); CAMLreturn(vres); }
/* given a return value in OCaml land, translate it to the return_val_t C structure */ return_val_t translate_return_value(value ocaml_result) { CAMLparam1(ocaml_result); CAMLlocal5(ocaml_shape, ocaml_strides, ocaml_data, ocaml_cur, ocaml_type); CAMLlocal1(v); return_val_t ret; if (Is_long(ocaml_result)) { // In this case, we know that the return code must have been Pass, // since the other two return codes have data. ret.return_code = RET_PASS; ret.results_len = 0; } else if (Tag_val(ocaml_result) == RET_FAIL) { ret.return_code = RET_FAIL; ret.results_len = caml_string_length(Field(ocaml_result, 0)); ret.error_msg = malloc(ret.results_len + 1); strcpy(ret.error_msg, String_val(Field(ocaml_result, 0))); } else if (Tag_val(ocaml_result) == RET_SUCCESS) { ocaml_cur = Field(ocaml_result, 0); ret.return_code = RET_SUCCESS; ret.results_len = ocaml_list_length(ocaml_cur); ret.results = (ret_t*)malloc(sizeof(ret_t) * ret.results_len); int i, j; host_val h; for (i = 0; i < ret.results_len; ++i) { v = Field(ocaml_cur, 0); h = create_host_val(v); ocaml_cur = Field(ocaml_cur, 1); // returning a scalar if (value_is_scalar(h)) { ret.results[i].is_scalar = 1; ocaml_type = (scalar_type)value_type_of(h); ret.results[i].data.scalar.ret_type = get_scalar_element_type(ocaml_type); // WARNING: // Tiny Memory Leak Ahead // ----------------------- // When scalar data is returned to the host language // on the heap, it should be manually deleted by the // host frontend if (type_is_bool(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.boolean = get_bool(h); } else if (type_is_int32(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.int32 = get_int32(h); } else if (type_is_int64(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.int64 = get_int64(h); } else if (type_is_float32(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.float32 = get_float64(h); } else if (type_is_float64(ocaml_type)) { ret.results[i].data.scalar.ret_scalar_value.float64 = get_float64(h); } else { caml_failwith("Unable to return scalar of this type\n"); } } else { // Pass the type ret.results[i].is_scalar = 0; ret.results[i].data.array.ret_type = array_type_of(h); // Pass the data ret.results[i].data.array.data = get_array_data(h); // Build the shape array ocaml_shape = value_get_shape(h); int shape_len = Wosize_val(ocaml_shape); ret.results[i].data.array.shape = (int*)malloc(shape_len * sizeof(int)); ret.results[i].data.array.shape_len = shape_len; for (j = 0; j < shape_len; ++j) { ret.results[i].data.array.shape[j] = Int_val(Field(ocaml_shape, j)); } // Build the strides array ocaml_strides = value_get_strides(h); int strides_len = Wosize_val(ocaml_strides); ret.results[i].data.array.strides_len = strides_len; ret.results[i].data.array.strides = (int*)malloc(strides_len * sizeof(int)); for (j = 0; j < strides_len; ++j) { ret.results[i].data.array.strides[j] = Int_val(Field(ocaml_strides, j)); } } } } CAMLreturnT(return_val_t, ret); }
value read_dump_file(value filename) { CAMLparam1(filename); CAMLlocal5(ocaml_var, ocaml_list_el1, ocaml_list_el2, ocaml_dyn_type, ocaml_dyn_aux); CAMLlocal2(ocaml_name, ocaml_hostval); printf("opening %s\n", String_val(filename)); FILE *ifile = fopen(String_val(filename), "r"); if (ifile == NULL) { ocaml_var = Val_int(0); CAMLreturn(ocaml_var); } int num_vars = 0; fread(&num_vars, sizeof(int), 1, ifile); if (num_vars == 0) { ocaml_var = Val_int(0); CAMLreturn(ocaml_var); } printf("parsing vars\n"); ocaml_list_el2 = caml_alloc_tuple(2); int i, j; int name_len, shape_len, type, num_bytes; int *shape; char *name, *data; for (i = 0; i < num_vars; ++i) { // Allocate the variable tuple of (name, hostval) ocaml_var = caml_alloc_tuple(2); // Build the name fread(&name_len, sizeof(int), 1, ifile); ocaml_name = caml_alloc_string(name_len); fread(String_val(ocaml_name), sizeof(char), name_len, ifile); Store_field(ocaml_var, 0, ocaml_name); printf("got var name: %s\n", String_val(ocaml_name)); // Build the shape fread(&shape_len, sizeof(int), 1, ifile); shape = (int*)malloc(shape_len * sizeof(int)); fread(shape, sizeof(int), shape_len, ifile); printf("got shape of len %d\n", shape_len); // Build the DynType fread(&ocaml_dyn_type, sizeof(value), 1, ifile); for (j = 0; j < shape_len; ++j) { ocaml_dyn_aux = ocaml_dyn_type; ocaml_dyn_type = caml_alloc(1, VecT); Store_field(ocaml_dyn_type, 0, ocaml_dyn_aux); } printf("built dyn_type\n"); // Get the num_bytes fread(&num_bytes, sizeof(int), 1, ifile); // Get the payload data = (char*)malloc(num_bytes); fread(data, 1, num_bytes, ifile); printf("got payload of %d bytes\n", num_bytes); // Build the HostVal ocaml_hostval = build_ocaml_hostval(num_bytes, ocaml_dyn_type, shape, shape_len, data); printf("built hostval from inputs\n"); Store_field(ocaml_var, 1, ocaml_hostval); // Insert the var into the list if (i == 0) { Store_field(ocaml_list_el2, 1, Val_int(0)); } else { Store_field(ocaml_list_el2, 1, ocaml_list_el1); } Store_field(ocaml_list_el2, 0, ocaml_var); if (i < num_vars - 1) { ocaml_list_el1 = ocaml_list_el2; ocaml_list_el2 = caml_alloc_tuple(2); } } fclose(ifile); CAMLreturn(ocaml_list_el2); }
CAMLprim value lwt_glib_poll(value val_fds, value val_count, value val_timeout) { gint timeout, lwt_timeout; long count; int i; GPollFD *gpollfd; gint events, revents; CAMLparam3(val_fds, val_count, val_timeout); CAMLlocal5(node, src, node_result, src_result, tmp); count = Long_val(val_count); g_main_context_dispatch(gc); g_main_context_prepare(gc, &max_priority); while (fds_count < count + (n_fds = g_main_context_query(gc, max_priority, &timeout, gpollfds, fds_count))) { free(gpollfds); fds_count = n_fds + count; gpollfds = lwt_unix_malloc(fds_count * sizeof (GPollFD)); } /* Clear all revents fields. */ for (i = 0; i < n_fds + count; i++) gpollfds[i].revents = 0; /* Add all Lwt fds. */ for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) { src = Field(node, 0); gpollfd = gpollfds + i; #if defined(LWT_ON_WINDOWS) gpollfd->fd = Handle_val(Field(src, 0)); #else gpollfd->fd = Int_val(Field(src, 0)); #endif events = 0; if (Bool_val(Field(src, 1))) events |= G_IO_IN; if (Bool_val(Field(src, 2))) events |= G_IO_OUT; gpollfd->events = events; } lwt_timeout = Int_val(val_timeout); if (timeout < 0 || (lwt_timeout >= 0 && lwt_timeout < timeout)) timeout = lwt_timeout; /* Do the blocking call. */ caml_enter_blocking_section(); g_main_context_get_poll_func(gc)(gpollfds, n_fds + count, timeout); caml_leave_blocking_section(); g_main_context_check(gc, max_priority, gpollfds, n_fds); /* Build the result. */ node_result = Val_int(0); for (i = n_fds, node = val_fds; i < n_fds + count; i++, node = Field(node, 1)) { gpollfd = gpollfds + i; src_result = caml_alloc_tuple(3); src = Field(node, 0); Field(src_result, 0) = Field(src, 0); revents = gpollfd->revents; if (revents & G_IO_HUP) { /* Treat HUP as ready. There's no point continuing to wait on this FD. */ if (gpollfd->events & G_IO_IN) revents |= G_IO_IN; if (gpollfd->events & G_IO_OUT) revents |= G_IO_OUT; } Field(src_result, 1) = Val_bool(revents & G_IO_IN); Field(src_result, 2) = Val_bool(revents & G_IO_OUT); tmp = caml_alloc_tuple(2); Field(tmp, 0) = src_result; Field(tmp, 1) = node_result; node_result = tmp; } CAMLreturn(node_result); }
CAMLprim value unix_select(value readfds, value writefds, value exceptfds, value timeout) { /* Event associated to handle */ DWORD nEventsCount; DWORD nEventsMax; HANDLE *lpEventsDone; /* Data for all handles */ LPSELECTDATA lpSelectData; LPSELECTDATA iterSelectData; /* Iterator for results */ LPSELECTRESULT iterResult; /* Iterator */ DWORD i; /* Error status */ DWORD err; /* Time to wait */ DWORD milliseconds; /* Is there static select data */ BOOL hasStaticData = FALSE; /* Wait return */ DWORD waitRet; /* Set of handle */ SELECTHANDLESET hds; DWORD hdsMax; LPHANDLE hdsData; /* Length of each list */ DWORD readfds_len; DWORD writefds_len; DWORD exceptfds_len; CAMLparam4 (readfds, writefds, exceptfds, timeout); CAMLlocal5 (read_list, write_list, except_list, res, l); CAMLlocal1 (fd); fd_set read, write, except; double tm; struct timeval tv; struct timeval * tvp; DEBUG_PRINT("in select"); err = 0; tm = Double_val(timeout); if (readfds == Val_int(0) && writefds == Val_int(0) && exceptfds == Val_int(0)) { DEBUG_PRINT("nothing to do"); if ( tm > 0.0 ) { enter_blocking_section(); Sleep( (int)(tm * 1000)); leave_blocking_section(); } read_list = write_list = except_list = Val_int(0); } else { if (fdlist_to_fdset(readfds, &read) && fdlist_to_fdset(writefds, &write) && fdlist_to_fdset(exceptfds, &except)) { DEBUG_PRINT("only sockets to select on, using classic select"); if (tm < 0.0) { tvp = (struct timeval *) NULL; } else { tv.tv_sec = (int) tm; tv.tv_usec = (int) (1e6 * (tm - (int) tm)); tvp = &tv; } enter_blocking_section(); if (select(FD_SETSIZE, &read, &write, &except, tvp) == -1) { err = WSAGetLastError(); DEBUG_PRINT("Error %ld occurred", err); } leave_blocking_section(); if (err) { DEBUG_PRINT("Error %ld occurred", err); win32_maperr(err); uerror("select", Nothing); } read_list = fdset_to_fdlist(readfds, &read); write_list = fdset_to_fdlist(writefds, &write); except_list = fdset_to_fdlist(exceptfds, &except); } else { nEventsCount = 0; nEventsMax = 0; lpEventsDone = NULL; lpSelectData = NULL; iterSelectData = NULL; iterResult = NULL; hasStaticData = 0; waitRet = 0; readfds_len = caml_list_length(readfds); writefds_len = caml_list_length(writefds); exceptfds_len = caml_list_length(exceptfds); hdsMax = MAX(readfds_len, MAX(writefds_len, exceptfds_len)); hdsData = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * hdsMax); if (tm >= 0.0) { milliseconds = 1000 * tm; DEBUG_PRINT("Will wait %d ms", milliseconds); } else { milliseconds = INFINITE; } /* Create list of select data, based on the different list of fd to watch */ DEBUG_PRINT("Dispatch read fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; for (l = readfds; l != Val_int(0); l = Field(l, 1)) { fd = Field(l, 0); if (!handle_set_mem(&hds, Handle_val(fd))) { handle_set_add(&hds, Handle_val(fd)); lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_READ, fd, i++); } else { DEBUG_PRINT("Discarding handle %x which is already monitor for read", Handle_val(fd)); } } handle_set_reset(&hds); DEBUG_PRINT("Dispatch write fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; for (l = writefds; l != Val_int(0); l = Field(l, 1)) { fd = Field(l, 0); if (!handle_set_mem(&hds, Handle_val(fd))) { handle_set_add(&hds, Handle_val(fd)); lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_WRITE, fd, i++); } else { DEBUG_PRINT("Discarding handle %x which is already monitor for write", Handle_val(fd)); } } handle_set_reset(&hds); DEBUG_PRINT("Dispatch exceptional fd"); handle_set_init(&hds, hdsData, hdsMax); i=0; for (l = exceptfds; l != Val_int(0); l = Field(l, 1)) { fd = Field(l, 0); if (!handle_set_mem(&hds, Handle_val(fd))) { handle_set_add(&hds, Handle_val(fd)); lpSelectData = select_data_dispatch(lpSelectData, SELECT_MODE_EXCEPT, fd, i++); } else { DEBUG_PRINT("Discarding handle %x which is already monitor for exceptional", Handle_val(fd)); } } handle_set_reset(&hds); /* Building the list of handle to wait for */ DEBUG_PRINT("Building events done array"); nEventsMax = list_length((LPLIST)lpSelectData); nEventsCount = 0; lpEventsDone = (HANDLE *)caml_stat_alloc(sizeof(HANDLE) * nEventsMax); iterSelectData = lpSelectData; while (iterSelectData != NULL) { /* Check if it is static data. If this is the case, launch everything * but don't wait for events. It helps to test if there are events on * any other fd (which are not static), knowing that there is at least * one result (the static data). */ if (iterSelectData->EType == SELECT_TYPE_STATIC) { hasStaticData = TRUE; }; /* Execute APC */ if (iterSelectData->funcWorker != NULL) { iterSelectData->lpWorker = worker_job_submit( iterSelectData->funcWorker, (void *)iterSelectData); DEBUG_PRINT("Job submitted to worker %x", iterSelectData->lpWorker); lpEventsDone[nEventsCount] = worker_job_event_done(iterSelectData->lpWorker); nEventsCount++; }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; DEBUG_PRINT("Need to watch %d workers", nEventsCount); /* Processing select itself */ enter_blocking_section(); /* There are worker started, waiting to be monitored */ if (nEventsCount > 0) { /* Waiting for event */ if (err == 0 && !hasStaticData) { DEBUG_PRINT("Waiting for one select worker to be done"); switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, FALSE, milliseconds)) { case WAIT_FAILED: err = GetLastError(); break; case WAIT_TIMEOUT: DEBUG_PRINT("Select timeout"); break; default: DEBUG_PRINT("One worker is done"); break; }; } /* Ordering stop to every worker */ DEBUG_PRINT("Sending stop signal to every select workers"); iterSelectData = lpSelectData; while (iterSelectData != NULL) { if (iterSelectData->lpWorker != NULL) { worker_job_stop(iterSelectData->lpWorker); }; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); }; DEBUG_PRINT("Waiting for every select worker to be done"); switch (WaitForMultipleObjects(nEventsCount, lpEventsDone, TRUE, INFINITE)) { case WAIT_FAILED: err = GetLastError(); break; default: DEBUG_PRINT("Every worker is done"); break; } } /* Nothing to monitor but some time to wait. */ else if (!hasStaticData) { Sleep(milliseconds); } leave_blocking_section(); DEBUG_PRINT("Error status: %d (0 is ok)", err); /* Build results */ if (err == 0) { DEBUG_PRINT("Building result"); read_list = Val_unit; write_list = Val_unit; except_list = Val_unit; iterSelectData = lpSelectData; while (iterSelectData != NULL) { for (i = 0; i < iterSelectData->nResultsCount; i++) { iterResult = &(iterSelectData->aResults[i]); l = alloc_small(2, 0); Store_field(l, 0, find_handle(iterResult, readfds, writefds, exceptfds)); switch (iterResult->EMode) { case SELECT_MODE_READ: Store_field(l, 1, read_list); read_list = l; break; case SELECT_MODE_WRITE: Store_field(l, 1, write_list); write_list = l; break; case SELECT_MODE_EXCEPT: Store_field(l, 1, except_list); except_list = l; break; } } /* We try to only process the first error, bypass other errors */ if (err == 0 && iterSelectData->EState == SELECT_STATE_ERROR) { err = iterSelectData->nError; } iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); } } /* Free resources */ DEBUG_PRINT("Free selectdata resources"); iterSelectData = lpSelectData; while (iterSelectData != NULL) { lpSelectData = iterSelectData; iterSelectData = LIST_NEXT(LPSELECTDATA, iterSelectData); select_data_free(lpSelectData); } lpSelectData = NULL; /* Free allocated events/handle set array */ DEBUG_PRINT("Free local allocated resources"); caml_stat_free(lpEventsDone); caml_stat_free(hdsData); DEBUG_PRINT("Raise error if required"); if (err != 0) { win32_maperr(err); uerror("select", Nothing); } } } DEBUG_PRINT("Build final result"); res = alloc_small(3, 0); Store_field(res, 0, read_list); Store_field(res, 1, write_list); Store_field(res, 2, except_list); DEBUG_PRINT("out select"); CAMLreturn(res); }
CAMLprim value bigstring_recvmmsg_assume_fd_is_nonblocking_stub( value v_fd, value v_iovecs, value v_count, value v_srcs, value v_lens) { CAMLparam5(v_fd, v_iovecs, v_count, v_srcs, v_lens); CAMLlocal5(v_iovec, v_buf, v_pos, v_len, v_sockaddrs); size_t total_len = 0; struct mmsghdr hdrs[Long_val(v_count)]; union sock_addr_union addrs[Long_val(v_count)]; struct iovec iovecs[Long_val(v_count)]; unsigned i; ssize_t n_read; int save_source_addresses; int fd; unsigned int count; save_source_addresses = Is_block(v_srcs); fd = Int_val(v_fd); count = (unsigned int) Long_val(v_count); if (count != Long_val(v_count)) { caml_invalid_argument("bigstring_recvmmsg_assume_fd_is_nonblocking_stub: " "v_count exceeds unsigned int"); } if (!Is_block(v_lens)) { caml_invalid_argument("bigstring_recvmmsg_assume_fd_is_nonblocking_stub: " "v_lens is not an array"); } if (Wosize_val(v_lens) < count) { caml_invalid_argument("bigstring_recvmmsg_assume_fd_is_nonblocking_stub: " "length v_lens < count"); } for (i = 0; i < count; i++) { hdrs[i].msg_hdr.msg_name = (save_source_addresses ? &addrs[i].s_gen : 0); hdrs[i].msg_hdr.msg_namelen = sizeof(addrs[i]); v_iovec = Field(v_iovecs, i); v_buf = Field(v_iovec, 0); v_pos = Field(v_iovec, 1); v_len = Field(v_iovec, 2); iovecs[i].iov_base = get_bstr(v_buf, v_pos); iovecs[i].iov_len = Long_val(v_len); total_len += iovecs[i].iov_len; hdrs[i].msg_hdr.msg_iov = &iovecs[i]; hdrs[i].msg_hdr.msg_iovlen = 1; hdrs[i].msg_hdr.msg_control = 0; hdrs[i].msg_hdr.msg_flags = 0; } if (total_len > THREAD_IO_CUTOFF) { caml_enter_blocking_section(); n_read = recvmmsg(fd, hdrs, count, 0, 0); caml_leave_blocking_section(); } else { n_read = recvmmsg(fd, hdrs, count, 0, 0); } if (n_read > count) { caml_failwith("bigstring_recvmmsg_assume_fd_is_nonblocking_stub: " "recvmmsg unexpectedly returned n_read > count"); } if (n_read == -1) { uerror("recvmmsg_assume_fd_is_nonblocking", Nothing); } else { if (save_source_addresses) { v_sockaddrs = Field(v_srcs, 0); if (!Is_block(v_sockaddrs)) { caml_invalid_argument("bigstring_recvmmsg_assume_fd_is_nonblocking_stub: " "v_sockaddrs is not an array"); } if (Wosize_val(v_sockaddrs) < count) { caml_invalid_argument("bigstring_recvmmsg_assume_fd_is_nonblocking_stub: " "length v_sockaddrs < count"); } for (i = 0; i < n_read; i++) { value addr = alloc_sockaddr(&addrs[i], hdrs[i].msg_hdr.msg_namelen, -1); Store_field(v_sockaddrs, i, addr); } } for (i = 0; i < n_read; i++) { Field(v_lens, i) = Val_long(hdrs[i].msg_len); } } CAMLreturn(Val_long(n_read)); }