CAMLprim value netsys_alloc_memory_pages(value addrv, value pv) { #if defined(HAVE_MMAP) && defined(HAVE_SYSCONF) && defined(MAP_ANON) void *start; size_t length; long pgsize; void *data; value r; start = (void *) Nativeint_val(addrv); if (start == 0) start=NULL; /* for formal reasons */ length = Int_val(pv); pgsize = sysconf(_SC_PAGESIZE); length = ((length - 1) / pgsize + 1) * pgsize; /* fixup */ data = mmap(start, length, PROT_READ|PROT_WRITE, MAP_PRIVATE | MAP_ANON, (-1), 0); if (data == (void *) -1) uerror("mmap", Nothing); r = alloc_bigarray_dims(BIGARRAY_C_LAYOUT | BIGARRAY_UINT8 | BIGARRAY_MAPPED_FILE, 1, data, length); return r; #else invalid_argument("Netsys_mem.alloc_memory_pages not available"); #endif }
CAMLprim value ml_gsl_odeiv_alloc_system(value func, value ojac, value dim) { const int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT | BIGARRAY_EXTERNAL; struct mlgsl_odeiv_params *p; gsl_odeiv_system *syst; value res; p=stat_alloc(sizeof (*p)); p->dim = Int_val(dim); p->closure = func; register_global_root(&(p->closure)); p->jac_closure = (ojac == Val_none ? Val_unit : Unoption(ojac)); register_global_root(&(p->jac_closure)); p->arr1 = alloc(Int_val(dim) * Double_wosize, Double_array_tag); register_global_root(&(p->arr1)); p->arr2 = alloc(Int_val(dim) * Double_wosize, Double_array_tag); register_global_root(&(p->arr2)); p->mat = (ojac == Val_none) ? Val_unit : alloc_bigarray_dims(barr_flags, 2, NULL, Int_val(dim), Int_val(dim)); register_global_root(&(p->mat)); syst=stat_alloc(sizeof (*syst)); syst->function = ml_gsl_odeiv_func; syst->jacobian = ml_gsl_odeiv_jacobian; syst->dimension = Int_val(dim); syst->params = p; Abstract_ptr(res, syst); return res; }
value camlidl_libbfd_bfd_get_section_contents( value _v_abfd, value _v_section, value _v_offset, value _v_count) { bfdp abfd; /*in*/ section_ptr section; /*in*/ char *location; /*out*/ file_ptr offset; /*in*/ bfd_size_type count; /*in*/ bfd_boolean _res; struct camlidl_ctx_struct _ctxs = { CAMLIDL_TRANSIENT, NULL }; camlidl_ctx _ctx = &_ctxs; value _vresult; value _vres[2] = { 0, 0, }; camlidl_ml2c_libbfd_bfdp(_v_abfd, &abfd, _ctx); camlidl_ml2c_libbfd_section_ptr(_v_section, §ion, _ctx); camlidl_ml2c_libbfd_file_ptr(_v_offset, &offset, _ctx); camlidl_ml2c_libbfd_bfd_size_type(_v_count, &count, _ctx); location = stat_alloc(count * sizeof(char )); _res = bfd_get_section_contents(abfd, section, location, offset, count); Begin_roots_block(_vres, 2) _vres[0] = camlidl_c2ml_libbfd_bfd_boolean(&_res, _ctx); _vres[1] = alloc_bigarray_dims( BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MANAGED, 1, location, count); _vresult = camlidl_alloc_small(2, 0); Field(_vresult, 0) = _vres[0]; Field(_vresult, 1) = _vres[1]; End_roots() camlidl_free(_ctx); return _vresult; }
void gsl_multimin_callback_df(const gsl_vector *x, void *params, gsl_vector *G) { int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT; struct callback_params *p=params; value x_barr, g_barr; int len = x->size; gsl_vector_view x_v, g_v; x_barr = alloc_bigarray_dims(barr_flags, 1, NULL, len); g_barr = alloc_bigarray_dims(barr_flags, 1, NULL, len); x_v = gsl_vector_view_array(Data_bigarray_val(x_barr), len); g_v = gsl_vector_view_array(Data_bigarray_val(g_barr), len); gsl_vector_memcpy(&x_v.vector, x); callback2(Field(p->closure, 1), x_barr, g_barr); gsl_vector_memcpy(G, &g_v.vector); }
/* MULTIROOT CALLBACKS */ int gsl_multiroot_callback(const gsl_vector *x, void *params, gsl_vector *F) { int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT; struct callback_params *p=params; value x_barr, f_barr; int len = x->size; gsl_vector_view x_v, f_v; x_barr = alloc_bigarray_dims(barr_flags, 1, NULL, len); f_barr = alloc_bigarray_dims(barr_flags, 1, NULL, len); x_v = gsl_vector_view_array(Data_bigarray_val(x_barr), len); f_v = gsl_vector_view_array(Data_bigarray_val(f_barr), len); gsl_vector_memcpy(&x_v.vector, x); callback2(p->closure, x_barr, f_barr); gsl_vector_memcpy(F, &f_v.vector); return GSL_SUCCESS; }
CAMLprim value netsys_grab(value addrv, value lenv) { void *start; size_t length; start = (void *) Nativeint_val(addrv); length = Long_val(lenv); return alloc_bigarray_dims(BIGARRAY_C_LAYOUT | BIGARRAY_UINT8, 1, start, length); }
int gsl_multiroot_callback_df(const gsl_vector *x, void *params, gsl_matrix *J) { int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT; struct callback_params *p=params; value x_barr, j_barr; int len = x->size; gsl_vector_view x_v; gsl_matrix_view j_v; x_barr = alloc_bigarray_dims(barr_flags, 1, NULL, len); j_barr = alloc_bigarray_dims(barr_flags, 2, NULL, len, len); x_v = gsl_vector_view_array(Data_bigarray_val(x_barr), len); j_v = gsl_matrix_view_array(Data_bigarray_val(j_barr), len, len); gsl_vector_memcpy(&x_v.vector, x); callback2(Field(p->closure, 1), x_barr, j_barr); gsl_matrix_memcpy(J, &j_v.matrix); return GSL_SUCCESS; }
/* MULTIFIT CALLBACKS */ int gsl_multifit_callback_f(const gsl_vector *X, void *params, gsl_vector *F) { int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT; struct callback_params *parms=params; value x_barr, f_barr; size_t p = X->size; size_t n = F->size; gsl_vector_view x_v, f_v; x_barr = alloc_bigarray_dims(barr_flags, 1, NULL, p); f_barr = alloc_bigarray_dims(barr_flags, 1, NULL, n); x_v = gsl_vector_view_array(Data_bigarray_val(x_barr), p); f_v = gsl_vector_view_array(Data_bigarray_val(f_barr), n); gsl_vector_memcpy(&x_v.vector, X); callback2(Field(parms->closure, 0), x_barr, f_barr); gsl_vector_memcpy(F, &f_v.vector); return GSL_SUCCESS; }
int gsl_multifit_callback_df(const gsl_vector *X, void *params, gsl_matrix *J) { int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT; struct callback_params *parms=params; value x_barr, j_barr; size_t p = X->size; size_t n = J->size1; gsl_vector_view x_v; gsl_matrix_view j_v; value res; x_barr = alloc_bigarray_dims(barr_flags, 1, NULL, p); j_barr = alloc_bigarray_dims(barr_flags, 2, NULL, n, p); x_v = gsl_vector_view_array(Data_bigarray_val(x_barr), p); j_v = gsl_matrix_view_array(Data_bigarray_val(j_barr), n, p); gsl_vector_memcpy(&x_v.vector, X); res=callback2(Field(parms->closure, 1), x_barr, j_barr); if(Is_exception_result(res)) return GSL_FAILURE; gsl_matrix_memcpy(J, &j_v.matrix); return GSL_SUCCESS; }
double gsl_multimin_callback_f(const gsl_vector *x, void *params) { int barr_flags = BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT; struct callback_params *p=params; value x_barr; int len = x->size; gsl_vector_view x_v; value res; x_barr = alloc_bigarray_dims(barr_flags, 1, NULL, len); x_v = gsl_vector_view_array(Data_bigarray_val(x_barr), len); gsl_vector_memcpy(&x_v.vector, x); res=callback(Field(p->closure, 0), x_barr); return Double_val(res); }
CAMLprim value netsys_alloc_aligned_memory(value alignv, value pv) { #if defined(HAVE_POSIX_MEMALIGN) size_t align = Long_val(alignv); size_t size = Long_val(pv); void * addr = NULL; int e; value r; e = posix_memalign(&addr, align, size); if (e != 0) unix_error(e, "posix_memalign", Nothing); r = alloc_bigarray_dims(BIGARRAY_C_LAYOUT | BIGARRAY_UINT8 | BIGARRAY_MANAGED, 1, addr, size); return r; #else invalid_argument("Netsys_mem.alloc_aligned_memory not available"); #endif }
CAMLprim value stub_gntshr_share_pages_batched(value xgh, value domid, value count, value writable) { CAMLparam4(xgh, domid, count, writable); CAMLlocal4(result, ml_refs, ml_refs_cons, ml_map); #ifdef HAVE_GNTSHR void *map; uint32_t *refs; int i; int c_count = Int_val(count); result = caml_alloc(2, 0); refs = malloc(c_count * sizeof(uint32_t)); map = xc_gntshr_share_pages(_G(xgh), Int_val(domid), c_count, refs, Bool_val(writable)); 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, Val_int(refs[i])); Store_field(ml_refs_cons, 1, ml_refs); ml_refs = ml_refs_cons; } ml_map = alloc_bigarray_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); }
/* CAML - C interface */ #include <caml/mlvalues.h> #include <caml/memory.h> #include <caml/alloc.h> #include <caml/fail.h> #include <caml/callback.h> #include <caml/bigarray.h> #include <caml/threads.h> /* audio */ static void __audio_callback(__attribute__((unused)) void *userdata, unsigned char *stream, int len) { caml_c_thread_register(); caml_leave_blocking_section(); caml_callback(*caml_named_value("ml_setaudiocallback"), alloc_bigarray_dims(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT, 1, stream, len)); caml_enter_blocking_section(); } value sdlstub_open_audio(value freq, value format, value channels, value samples) { CAMLparam4 (freq, format, channels, samples); CAMLlocal1 (result); SDL_AudioSpec input, output; result = caml_alloc (6, 0); set_audiospec(&input, Int_val(freq),Int_val(format),Int_val(channels),Int_val(samples), __audio_callback); set_audiospec(&output, 0,0,0,0, NULL); SDL_OpenAudio(&input, &output); Store_field (result, 0, Val_int((int)output.freq)); Store_field (result, 1, Val_int((int)output.format));
value fortran_filltab(value unit) { filltab_(); return alloc_bigarray_dims(BIGARRAY_FLOAT32 | BIGARRAY_FORTRAN_LAYOUT, 2, ftab_, 8, 6); }
value c_filltab(value unit) { filltab(); return alloc_bigarray_dims(BIGARRAY_FLOAT64 | BIGARRAY_C_LAYOUT, 2, ctab, DIMX, DIMY); }
CAMLprim value netsys_map_file(value fdv, value posv, value addrv, value sharedv, value sizev) { #if defined(HAVE_MMAP) && defined(HAVE_SYSCONF) && !defined(_WIN32) int fd, shared; off_t pos, savepos, eofpos, basize0; /* Att: pos might be 64 bit even on 32 bit systems! */ void *addr, *eff_addr; intnat size; uintnat basize; int64 pos0; char c; uintnat pagesize, delta; fd = Int_val(fdv); pos0 = Int64_val(posv); if (((int64) ((off_t) pos0)) != pos0) failwith("Netsys_mem: large files not supported on this OS"); pos = pos0; addr = (void *) Nativeint_val(addrv); if (addr == 0) addr = NULL; shared = Bool_val(sharedv) ? MAP_SHARED : MAP_PRIVATE; size = Long_val(sizev); pagesize = sysconf(_SC_PAGESIZE); savepos = lseek(fd, 0, SEEK_CUR); if (savepos == -1) uerror("lseek", Nothing); eofpos = lseek(fd, 0, SEEK_END); if (eofpos == -1) uerror("lseek", Nothing); if (size == -1) { if (eofpos < pos) failwith("Netsys_mem: cannot mmap - file position exceeds file size"); basize0 = eofpos - pos; if (((off_t) ((uintnat) basize0)) != basize0) failwith("Netsys_mem: cannot mmap - file too large"); basize = (uintnat) basize0; } else { if (size < 0) invalid_argument("netsys_map_file"); if (eofpos - pos < size) { if (lseek(fd, pos + size - 1, SEEK_SET) == -1) uerror("lseek", Nothing); c = 0; if (write(fd, &c, 1) != 1) uerror("write", Nothing); } basize = size; } lseek(fd, savepos, SEEK_SET); delta = (uintnat) (pos % pagesize); eff_addr = mmap(addr, basize + delta, PROT_READ | PROT_WRITE, shared, fd, pos - delta); if (eff_addr == (void*) MAP_FAILED) uerror("mmap", Nothing); eff_addr = (void *) ((uintnat) eff_addr + delta); return alloc_bigarray_dims(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT | BIGARRAY_MAPPED_FILE, 1, eff_addr, basize); #else invalid_argument("Netsys_mem.memory_map_file not available"); #endif }
value netsys_copy_value(value flags, value orig) { int code; int cflags; intnat start_offset, bytelen; mlsize_t wosize; char *dest, *dest_end, *extra_block, *extra_block_end; int color; struct named_custom_ops bigarray_ops; struct named_custom_ops int32_ops; struct named_custom_ops int64_ops; struct named_custom_ops nativeint_ops; CAMLparam2(orig,flags); CAMLlocal1(block); /* First test on trivial cases: */ if (Is_long(orig) || Wosize_val(orig) == 0) { CAMLreturn(orig); }; code = prep_stat_tab(); if (code != 0) goto exit; code = prep_stat_queue(); if (code != 0) goto exit; cflags = caml_convert_flag_list(flags, init_value_flags); /* fprintf (stderr, "counting\n"); */ /* Count only! */ code = netsys_init_value_1(stat_tab, stat_queue, NULL, NULL, orig, (cflags & 1) ? 1 : 0, /* enable_bigarrays */ (cflags & 2) ? 1 : 0, /* enable_customs */ 1, /* enable_atoms */ 1, /* simulate */ NULL, NULL, 0, &start_offset, &bytelen); if (code != 0) goto exit; /* fprintf (stderr, "done counting bytelen=%ld\n", bytelen); */ /* set up the custom ops. We always set this, because we assume that the values in [orig] are not trustworthy */ bigarray_ops.name = "_bigarray"; bigarray_ops.ops = Custom_ops_val(alloc_bigarray_dims(CAML_BA_UINT8 | BIGARRAY_C_LAYOUT, 1, NULL, 1)); bigarray_ops.next = &int32_ops; int32_ops.name = "_i"; int32_ops.ops = Custom_ops_val(caml_copy_int32(0)); int32_ops.next = &int64_ops; int64_ops.name = "_j"; int64_ops.ops = Custom_ops_val(caml_copy_int64(0)); int64_ops.next = &nativeint_ops; nativeint_ops.name = "_n"; nativeint_ops.ops = Custom_ops_val(caml_copy_nativeint(0)); nativeint_ops.next = NULL; /* alloc */ extra_block = NULL; extra_block_end = NULL; /* shamelessly copied from intern.c */ wosize = Wosize_bhsize(bytelen); /* fprintf (stderr, "wosize=%ld\n", wosize); */ if (wosize > Max_wosize) { /* Round desired size up to next page */ asize_t request = ((bytelen + Page_size - 1) >> Page_log) << Page_log; extra_block = caml_alloc_for_heap(request); if (extra_block == NULL) caml_raise_out_of_memory(); extra_block_end = extra_block + request; color = caml_allocation_color(extra_block); dest = extra_block; dest_end = dest + bytelen; block = Val_hp(extra_block); } else {