CAMLprim value cstring_to_binary_array (value dst_arr, value dst_idx, value dst_len, value src_str) { CAMLparam4 (dst_arr, dst_idx, dst_len, src_str); int len = string_length (src_str), idx = Long_val(dst_idx), dlen = Long_val(dst_len); if (idx + dlen > Bigarray_val(dst_arr)->dim[0] || len > dlen) invalid_argument ("Binarray.write_sz"); memcpy ((char *) Data_bigarray_val(dst_arr) + idx, String_val(src_str), len); memset ((char *) Data_bigarray_val(dst_arr) + idx + len, 0, dlen - len); CAMLreturn (Val_unit); }
value fortran_printtab(value ba) { int dimx = Bigarray_val(ba)->dim[0]; int dimy = Bigarray_val(ba)->dim[1]; printtab_(Data_bigarray_val(ba), &dimx, &dimy); return Val_unit; }
/* T.F. additions - same style. We use these to distribute mesh info */ value caml_mpi_broadcast_bigarray_float(value data, value root, value comm) { mlsize_t len = Bigarray_val(data)->dim[0]; double *d = Data_bigarray_val(data); MPI_Bcast(d, len, MPI_DOUBLE, Int_val(root), Comm_val(comm)); return Val_unit; }
/* Fill a buffer from a slice of a Binarary.t */ CAMLprim value string_from_binary_array (value src_arr, value buffer, value src_idx, value src_len, value dst_idx) { CAMLparam5 (src_arr, buffer, src_idx, src_len, dst_idx); char *dst = (String_val(buffer)) + (Long_val(dst_idx)); memmove (dst, (char *) Data_bigarray_val(src_arr) + (Long_val(src_idx)), Long_val(src_len)); CAMLreturn (Val_unit); }
CAMLprim value string_to_binary_array (value dst_arr, value dst_idx, value src_str) { CAMLparam3 (dst_arr, dst_idx, src_str); int len = string_length (src_str), idx = Long_val(dst_idx); if (idx + len > Bigarray_val(dst_arr)->dim[0]) invalid_argument ("Binarray.write"); memcpy ((char *) Data_bigarray_val(dst_arr) + idx, String_val(src_str), len); CAMLreturn (Val_unit); }
value caml_mpi_broadcast_bigarray_nativeint(value data, value root, value comm) { mlsize_t len = Bigarray_val(data)->dim[0]; double *d = Data_bigarray_val(data); MPI_Bcast(d, len, MPI_LONG, Int_val(root), Comm_val(comm)); /* According to the docs, MPI_LONG is right, even on LC64 machines. */ return Val_unit; }
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); }
CAMLprim value string_of_binary_array (value src_arr, value src_idx, value src_len) { CAMLparam3 (src_arr, src_idx, src_len); CAMLlocal1 (retval); int len = Long_val(src_len); retval = alloc_string (len); memmove (String_val(retval), (char *) Data_bigarray_val(src_arr) + (Long_val(src_idx)), len); CAMLreturn (retval); }
/* 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; }
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; }
CAMLprim value ocaml_c_fastfield_eval_bigarray(value ml_funptr, value ml_arr_in, value ml_arr_out) { CAMLparam3(ml_funptr, ml_arr_in, ml_arr_out); int success; field_function *fun; fun=(field_function *)Field(ml_funptr,0); if(fun==0) { CAMLreturn(Val_bool(0)); } success=fun(Data_bigarray_val(ml_arr_in),Data_bigarray_val(ml_arr_out)); CAMLreturn(Val_bool(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; }
CAMLprim value cstring_of_binary_array (value src_arr, value src_idx, value src_len) { CAMLparam3 (src_arr, src_idx, src_len); CAMLlocal1 (retval); int len = Long_val(src_len); char *retstr = (char *) calloc (len + 1, 1); if (retstr == NULL) failwith ("unable to allocate internal buffer"); memcpy (retstr, (char *) Data_bigarray_val(src_arr) + (Long_val(src_idx)), len); retval = copy_string (retstr); free (retstr); CAMLreturn (retval); }
value sankoff_CAML_filter_character(value this_eltarr, value ecode_bigarr, value get_comp) { CAMLparam3(this_eltarr,ecode_bigarr,get_comp); CAMLlocal1(res); int get_complementary = Int_val(get_comp); int * ecode_arr = (int*) Data_bigarray_val(ecode_bigarr); eltarr_p eap; Sankoff_eltarr_custom_val(eap,this_eltarr); int num_elts=eap->num_elts; int res_num_elts=0;//must init to 0 int i; elt_p ep; int * sign_arr = (int*)calloc(num_elts,sizeof(int)); for (i=0;i<num_elts;i++) { ep = &((eap->elts)[i]); if(get_complementary) { if( int_array_is_mem(ecode_arr,num_elts,ep->ecode) ) { sign_arr[i]=0; } else { sign_arr[i]=1; res_num_elts++; } } else { if( int_array_is_mem(ecode_arr,num_elts,ep->ecode) ) { sign_arr[i]=1; res_num_elts++; } else sign_arr[i]=0; } } eltarr_p res_eap; res_eap = (eltarr_p)calloc(1,sizeof(struct elt_arr)); int num_states = eap->num_states; res_eap->code = eap->code; res_eap->num_states = eap->num_states; res_eap->num_elts = res_num_elts; res_eap->tcm = (int*)calloc(num_states*num_states,sizeof(int)); res_eap->is_identity = eap->is_identity; memcpy (res_eap->tcm,eap->tcm,sizeof(int)*num_states*num_states); res_eap->elts = (elt_p)calloc(res_num_elts,sizeof(struct elt)); elt_p res_elts = res_eap->elts; int j=0; for (i=0;i<num_elts;i++) { if(sign_arr[i]==1) { sankoff_create_empty_elt(&(res_elts[j]),num_states,-1); sankoff_clone_elt(&(res_elts[j]),&((eap->elts)[i])); j++; } } free(sign_arr); assert(j==res_num_elts); res = caml_alloc_custom(&sankoff_custom_operations_eltarr,sizeof(eltarr_p),1,alloc_custom_max); Sankoff_return_eltarr(res) = res_eap; CAMLreturn(res); }
CAMLprim value stub_gntshr_munmap_batched(value xgh, value share) { CAMLparam2(xgh, share); CAMLlocal1(ml_map); #ifdef HAVE_GNTSHR ml_map = Field(share, 1); int size = Bigarray_val(ml_map)->dim[0]; int pages = size >> XC_PAGE_SHIFT; #ifdef linux /* Bug in xen-4.4 libxc xc_linux_osdep implementation, work-around by using the kernel interface directly. */ int result = munmap(Data_bigarray_val(ml_map), size); #else int result = xc_gntshr_munmap(_G(xgh), Data_bigarray_val(ml_map), pages); #endif if(result != 0) failwith_xc(_G(xgh)); #else gntshr_missing(); #endif CAMLreturn(Val_unit); }
value ml_cv_convert_bigarray( value converter, value src, value dest ) { CAMLparam3( converter, src, dest ); int n; n = Bigarray_val( dest )->dim[0]; if ( n > Bigarray_val( src )->dim[0] ) { caml_raise_with_arg( *caml_named_value( "ut status exception" ), Val_int( UT_BAD_ARG ) ); } if ( (Bigarray_val( src )->flags & BIGARRAY_KIND_MASK) == BIGARRAY_FLOAT32 ) { cv_convert_floats( UD_cv_converter_val( converter ), Data_bigarray_val( src ), n, Data_bigarray_val( dest ) ); } else if ( (Bigarray_val( src )->flags & BIGARRAY_KIND_MASK) == BIGARRAY_FLOAT64 ) { cv_convert_doubles( UD_cv_converter_val( converter ), Data_bigarray_val( src ), n, Data_bigarray_val( dest ) ); } else { caml_raise_with_arg( *caml_named_value( "ut status exception" ), Val_int( UT_BAD_ARG ) ); } CAMLreturn( Val_unit ); }
CAMLprim value ml_sqlite3_column_blob_big (value s, value i) { CAMLparam1(s); CAMLlocal1(r); intnat len; const void * data; len = sqlite3_column_bytes (Sqlite3_stmt_val (s), Int_val (i)); r = alloc_bigarray (BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT, 1, NULL, &len); data = sqlite3_column_blob (Sqlite3_stmt_val (s), Int_val(i)); memcpy (Data_bigarray_val(r), data, len); CAMLreturn(r); }
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; }
CAMLprim value cstruct_md5sum(value buffer, value offset, value length) { CAMLparam3(buffer, offset, length); CAMLlocal1(result); unsigned char* data; result = caml_alloc_string(MD5_DIGEST_LENGTH); data = (unsigned char*) Data_bigarray_val(buffer); data += Int_val(offset); MD5(data, Int_val(length), (unsigned char*) String_val(result)); CAMLreturn(result); }
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 stub_sha1_update_bigarray(value ctx, value buf, value pos, value len) { CAMLparam4(ctx, buf, pos, len); struct sha1_ctx ctx_dup; unsigned char *data = Data_bigarray_val(buf); ctx_dup = *GET_CTX_STRUCT(ctx); caml_release_runtime_system(); sha1_update(&ctx_dup, data + Long_val(pos), Long_val(len)); caml_acquire_runtime_system(); *GET_CTX_STRUCT(ctx) = ctx_dup; CAMLreturn(Val_unit); }
static int ml_gsl_odeiv_jacobian(double t, const double y[], double *dfdy, double dfdt[], void *params) { struct mlgsl_odeiv_params *p = params; value res, args[4]; args[0] = copy_double(t); memcpy(Double_array_val(p->arr1), y, p->dim * sizeof(double)); args[1] = p->arr1; Data_bigarray_val(p->mat) = dfdy; args[2] = p->mat; args[3] = p->arr2; res = callbackN_exn(p->jac_closure, 4, args); if(Is_exception_result(res)) return GSL_FAILURE; memcpy(dfdt, Double_array_val(p->arr2), p->dim * sizeof(double)); return GSL_SUCCESS; }
CAMLprim value ml_osmesamakecurrent( value ctx, value buffer_ba, value _type, value width, value height ) { GLenum type; GLboolean ret; void *buffer; buffer = (void *) Data_bigarray_val(buffer_ba); if (Int_val(_type) != 0) caml_invalid_argument("OSMesaMakeCurrent"); type = GL_UNSIGNED_BYTE; ret = OSMesaMakeCurrent( (OSMesaContext) ctx, buffer, type, Int_val(width), Int_val(height) ); if (!ret) caml_failwith("OSMesaMakeCurrent"); return Val_unit; }
CAMLprim value digest_array (value v_iarr) { CAMLparam1(v_iarr); CAMLlocal1(result); MD5Context context; int len = Bigarray_val(v_iarr)->dim[0]; unsigned char *buf = Data_bigarray_val(v_iarr); MD5Init (&context); while (len > 0) { int block = (len > 8192) ? 8192 : len; MD5Update (&context, buf, block); buf += block; len -= block; } result = alloc_string (16); MD5Final (&Byte_u(result, 0), &context); CAMLreturn(result); }
static void ml_sqlite3_release_big (void *data) { value c, p; p = Val_emptylist; c = big_root; while (c != Val_emptylist) { void *d = Data_bigarray_val (Field (c, 0)); value tl = Field (c, 1); if (d == data) { if (p == Val_emptylist) /* c is the head */ big_root = tl; else Store_field(p, 1, tl); return; } p = c; c = tl; } /* should not reach this point */ }
CAMLprim value magick_loader(value input) { CAMLparam1(input); CAMLlocal2(pixel_matrix, res); Image *image_bloc; int image_type_code; int components; GLenum format; ExceptionInfo exception; GetExceptionInfo(&exception); { if (IsMagickInstantiated() == MagickFalse) { InitializeMagick(getenv("PWD")); } { ImageInfo *image_info; image_info = CloneImageInfo((ImageInfo *) NULL); switch (Tag_val(input)) { /* given a filename of an image */ case 0: (void) strcpy(image_info->filename, String_val(Field(input,0))); image_bloc = ReadImage(image_info, &exception); break; /* given the image data in a buffer */ case 1: image_bloc = BlobToImage( image_info, (void *)String_val(Field(input,0)), caml_string_length(Field(input,0)), &exception); break; } DestroyImageInfo(image_info); } if (exception.severity != UndefinedException) { if (image_bloc != (Image *) NULL) { DestroyImage(image_bloc); } DestroyExceptionInfo(&exception); caml_failwith( exception.reason ); /* @TODO exception.description */ } if (image_bloc == (Image *) NULL) { DestroyExceptionInfo(&exception); caml_failwith("read image failed"); } } { ImageType image_type; image_type = GetImageType( image_bloc, &exception ); if (exception.severity != UndefinedException) caml_failwith( exception.reason ); image_type_code = Val_ImageType(image_type, &components); if ( image_type_code == 11 ) caml_failwith("getting image type failed"); } { unsigned long x, y; unsigned long columns, rows; PixelPacket pixel; columns = image_bloc->columns; rows = image_bloc->rows; const PixelPacket * pixel_packet_array; pixel_packet_array = AcquireImagePixels( image_bloc, 0, 0, columns, rows, &exception ); if (exception.severity != UndefinedException) { caml_failwith(exception.reason); } { unsigned char *image; long ndx; long dims[3]; dims[0] = columns; dims[1] = rows; dims[2] = components; pixel_matrix = alloc_bigarray(BIGARRAY_UINT8 | BIGARRAY_C_LAYOUT, 3, NULL, dims); image = Data_bigarray_val(pixel_matrix); for (x=0; x < columns; ++x) { for (y=0; y < rows; ++y) { pixel = pixel_packet_array[(columns * y) + x]; ndx = (columns * y * components) + (x * components); switch (components) { case 1: image[ndx + 0] = pixel.red / SCALE; break; case 2: image[ndx + 0] = pixel.red / SCALE; image[ndx + 1] = ( MaxMap - pixel.opacity ) / SCALE; break; case 3: image[ndx + 0] = pixel.red / SCALE; image[ndx + 1] = pixel.green / SCALE; image[ndx + 2] = pixel.blue / SCALE; break; case 4: image[ndx + 0] = pixel.red / SCALE; image[ndx + 1] = pixel.green / SCALE; image[ndx + 2] = pixel.blue / SCALE; image[ndx + 3] = ( MaxMap - pixel.opacity ) / SCALE; break; } } } } switch (components) { case 1: format = GL_LUMINANCE; break; case 2: format = GL_LUMINANCE_ALPHA; break; case 3: format = GL_RGB; break; case 4: format = GL_RGBA; break; } res = alloc_tuple(5); Store_field(res, 0, pixel_matrix ); Store_field(res, 1, Val_long(columns) ); Store_field(res, 2, Val_long(rows) ); Store_field(res, 3, Val_internal_format(components) ); Store_field(res, 4, Val_pixel_data_format(format) ); } DestroyExceptionInfo(&exception); DestroyImage(image_bloc); CAMLreturn(res); }
value sankoff_CAML_create_eltarr (value is_identity, value taxon_code, value code, value number_of_states, value ecode_bigarr, value states_bigarr, value tcm_bigarr) { CAMLparam5(is_identity,taxon_code,code,number_of_states,ecode_bigarr); CAMLxparam2(states_bigarr,tcm_bigarr); CAMLlocal1(res); int num_states; num_states = Int_val(number_of_states); int tcode = Int_val(taxon_code); int iside = Int_val(is_identity); int mycode = Int_val(code); int * cost_mat; int dimcm1, dimcm2; int * states_arrarr; int dims1, dims2; int * ecode_arr; int dim; ecode_arr = (int*) Data_bigarray_val(ecode_bigarr); dim = Bigarray_val(ecode_bigarr)->dim[0];//number of elts states_arrarr = (int*) Data_bigarray_val(states_bigarr); dims1 = Bigarray_val(states_bigarr)->dim[0]; //number of elts dims2 = Bigarray_val(states_bigarr)->dim[1]; //number of states in each elt if (dim!=dims1) failwith ("sankoff.c, size of ecode array != number of charactors"); if (dims2!= num_states) failwith ("sankoff.c, size of states array != number of states"); cost_mat = (int*) Data_bigarray_val(tcm_bigarr); dimcm1 = Bigarray_val(tcm_bigarr)->dim[0];//number of states dimcm2 = Bigarray_val(tcm_bigarr)->dim[1];//number of states if ((dimcm1!=dimcm2)||(dimcm1!=dims2)) failwith ("sankoff.c, wrong size of costmat between states"); eltarr_p neweltarr; //alloc struct elt_arr neweltarr = (eltarr_p)calloc(1,sizeof(struct elt_arr)); neweltarr->code = mycode; neweltarr->taxon_code = tcode; neweltarr->left_taxon_code = tcode; neweltarr->right_taxon_code = tcode; neweltarr->sum_cost = 0; neweltarr->num_states = dimcm1; neweltarr->num_elts = dim; neweltarr->is_identity = iside; //alloc its pointers neweltarr->tcm = (int*)calloc(dimcm1*dimcm2,sizeof(int)); memcpy(neweltarr->tcm,cost_mat,sizeof(int) * dimcm1 * dimcm2); neweltarr->elts = (elt_p)calloc(dim,sizeof(struct elt)); int i; int j; int * states_arr; elt_p newelt; for (i=0;i<dim;i++) { newelt = &((neweltarr->elts)[i]); assert(newelt!=NULL); newelt->ecode = ecode_arr[i]; newelt->num_states = num_states; newelt->states = (int*)calloc( num_states, sizeof(int) ); newelt->leftstates = (int*)calloc( num_states, sizeof(int) ); newelt->rightstates = (int*)calloc( num_states, sizeof(int) ); //for new median_3 if (median_3_su) { newelt->left_costdiff_mat = (int*)calloc(num_states*num_states,sizeof(int)); newelt->right_costdiff_mat = (int*)calloc(num_states*num_states,sizeof(int)); } states_arr = sankoff_move_to_line_i(states_arrarr,dims1,dims2,i); //the infinity on ocaml side is diff from here, so we pass -1 instead //memcpy(newelt->states,states_arr,sizeof(int)*num_states); for (j=0;j<num_states;j++) { (newelt->states)[j] = ( states_arr[j]==(-1) ) ? infinity : states_arr[j]; } newelt->beta = (int*)calloc(num_states,sizeof(int)); newelt->e = (int*)calloc(num_states,sizeof(int)); newelt->m = (int*)calloc(num_states,sizeof(int)); sankoff_canonize(newelt,cost_mat); } res = caml_alloc_custom (&sankoff_custom_operations_eltarr,sizeof (eltarr_p), 1,alloc_custom_max); Sankoff_return_eltarr(res) = neweltarr; CAMLreturn(res); }
/* As above, but unsafe; the advantage is that you don't need to know how long it might be. */ CAMLprim value unsafe_cstring_of_binary_array (value src_arr, value src_idx) { return copy_string ((char *) Data_bigarray_val(src_arr) + (Int_val(src_idx))); }
t_value ml_glteximage3dwithpixels_native ( value _target_3d, value level, value _internal_format, value width, value height, value depth, value _pixel_data_format, value _pixel_data_type, value pixels ) { CAMLparam5 (_target_3d, level, _internal_format, width, height); CAMLxparam4 (depth, _pixel_data_format, _pixel_data_type, pixels); GLenum pixel_data_format = conv_pixel_data_format_table[Int_val(_pixel_data_format)]; GLenum pixel_data_type = conv_pixel_data_type_table[Int_val(_pixel_data_type)]; GLenum target_3d = conv_target_3d_table[Int_val(_target_3d)]; GLint internal_format = conv_internal_format_table[Int_val(_internal_format)]; glTexImage3D( target_3d, Int_val(level), internal_format, Int_val(width), Int_val(height), Int_val(depth), 0, pixel_data_format, pixel_data_type, (const GLvoid *) Data_bigarray_val(pixels) ); CAMLreturn (Val_unit); }
value c_printtab(value ba) { printtab(Data_bigarray_val(ba)); return Val_unit; }