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 {
