CAMLprim value LFUN(linspace_stub)(value vY, value va, value vb, value vN) { CAMLparam1(vY); integer i, GET_INT(N); REAL ar = Double_field(va, 0), ai = Double_field(va, 1), N1 = N - 1., hr = (Double_field(vb, 0) - ar) / N1, hi = (Double_field(vb, 1) - ai) / N1, xr = ar, xi = ai; VEC_PARAMS1(Y); caml_enter_blocking_section(); /* Allow other threads */ for (i = 1; i <= N; i++) { Y_data->r = xr; Y_data->i = xi; Y_data++; xr = ar + i * hr; xi = ai + i * hi; } caml_leave_blocking_section(); /* Disallow other threads */ CAMLreturn(Val_unit); }
CAMLprim value ocaml_c_fastfield_eval(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)); } #ifdef ARCH_ALIGN_DOUBLE { fprintf(stderr,"The fastfields module does not (yet) support platforms which have ARCH_ALIGN_DOUBLE defined. Exiting.\n"); exit(1); } #endif /* See the discussion of this in the thread "C interface style question" in fa.caml http://groups.google.com/group/fa.caml/browse_thread/thread/5c2c56f94be1c37d/4d67a0a52a989dce#4d67a0a52a989dce or (caml weekly news) http://alan.petitepomme.net/cwn/2006.02.14.html#5 */ success=fun(&(Double_field(ml_arr_in,0)),&(Double_field(ml_arr_out,0))); /* This is stretching the rules a bit concerning the use of Double_field... */ CAMLreturn(Val_bool(success)); }
CAMLprim value ml_cairo_in_fill (value v_cr, value p) { cairo_bool_t c_ret; c_ret = cairo_in_fill (cairo_t_val (v_cr), Double_field (p, 0), Double_field (p, 1)); check_cairo_status (v_cr); return Val_bool (c_ret); }
CAMLprim value ml_gsl_fit_mul_est(value x, value coeffs) { double y,y_err; gsl_fit_mul_est(Double_val(x), Double_field(coeffs, 0), Double_field(coeffs, 1), &y, &y_err); return copy_two_double_arr(y, y_err); }
CAMLprim value LFUN(logspace_stub)(value vY, value va, value vb, value vbase, value vN) { CAMLparam1(vY); integer i, GET_INT(N); REAL ar = Double_field(va, 0), ai = Double_field(va, 1), N1 = N - 1., hr = (Double_field(vb, 0) - ar) / N1, hi = (Double_field(vb, 1) - ai) / N1, base = Double_val(vbase), xr = ar, xi = ai; VEC_PARAMS1(Y); caml_enter_blocking_section(); /* Allow other threads */ if (base == 2.0) for (i = 1; i <= N; i++) { Y_data->r = exp2(xr); Y_data->i = exp2(xi); Y_data++; xr = ar + i * hr; xi = ai + i * hi; } else if (base == 10.0) for (i = 1; i <= N; i++) { Y_data->r = exp10(xr); Y_data->i = exp10(xi); Y_data++; xr = ar + i * hr; xi = ai + i * hi; } else if (base == 2.7182818284590452353602874713526625L) for (i = 1; i <= N; i++) { Y_data->r = exp(xr); Y_data->i = exp(xi); Y_data++; xr = ar + i * hr; xi = ai + i * hi; } else { double log_base = log(base); for (i = 1; i <= N; i++) { Y_data->r = exp(xr * log_base); Y_data->i = exp(xi * log_base); Y_data++; xr = ar + i * hr; xi = ai + i * hi; } } caml_leave_blocking_section(); /* Disallow other threads */ CAMLreturn(Val_unit); }
static void copy_vertices (float *p, int num_vertices, value a_v) { int i, k; for (i = 0, k = 0; i < num_vertices; ++i, p += 3) { p[0] = Double_field (a_v, k++); p[1] = Double_field (a_v, k++); p[2] = Double_field (a_v, k++); } }
CAMLprim value ml_cairo_device_to_user_distance (value cr, value p) { double x, y; x = Double_field (p, 0); y = Double_field (p, 1); cairo_device_to_user_distance (cairo_t_val (cr), &x, &y); check_cairo_status (cr); return ml_cairo_point (x, y); }
static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval) { struct caml_ba_array * b = Caml_ba_array_val(vb); intnat index[CAML_BA_MAX_NUM_DIMS]; int i; intnat offset; /* Check number of indices = number of dimensions of array (maybe not necessary if ML typing guarantees this) */ if (nind != b->num_dims) caml_invalid_argument("Bigarray.set: wrong number of indices"); /* Compute offset and check bounds */ for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]); offset = caml_ba_offset(b, index); /* Perform write */ switch (b->flags & CAML_BA_KIND_MASK) { default: Assert(0); #ifdef _KERNEL #else case CAML_BA_FLOAT32: ((float *) b->data)[offset] = Double_val(newval); break; case CAML_BA_FLOAT64: ((double *) b->data)[offset] = Double_val(newval); break; #endif case CAML_BA_SINT8: case CAML_BA_UINT8: ((int8 *) b->data)[offset] = Int_val(newval); break; case CAML_BA_SINT16: case CAML_BA_UINT16: ((int16 *) b->data)[offset] = Int_val(newval); break; case CAML_BA_INT32: ((int32 *) b->data)[offset] = Int32_val(newval); break; case CAML_BA_INT64: ((int64 *) b->data)[offset] = Int64_val(newval); break; case CAML_BA_NATIVE_INT: ((intnat *) b->data)[offset] = Nativeint_val(newval); break; case CAML_BA_CAML_INT: ((intnat *) b->data)[offset] = Long_val(newval); break; #ifdef _KERNEL #else case CAML_BA_COMPLEX32: { float * p = ((float *) b->data) + offset * 2; p[0] = Double_field(newval, 0); p[1] = Double_field(newval, 1); break; } case CAML_BA_COMPLEX64: { double * p = ((double *) b->data) + offset * 2; p[0] = Double_field(newval, 0); p[1] = Double_field(newval, 1); break; } #endif } return Val_unit; }
CAMLprim value segment_intersect_line(value segment1, value segment2) { CAMLparam2(segment1, segment2); CAMLlocal1(record_vector); Segment s = Segment_val(segment1); Segment s2 = Segment_val(segment2); Vector out; if (s.intersect_line(s2, out)) { record_vector = caml_alloc_small(2, Double_array_tag); Double_field(record_vector, 0) = out.x; Double_field(record_vector, 1) = out.y; CAMLreturn(Val_some(record_vector)); } else { CAMLreturn(Val_none); } }
void SfFloatRect_val(sfFloatRect *rect, value float_rect) { /* if (Tag_val(float_rect) == Double_array_tag) { */ rect->left = Double_field(float_rect,0); rect->top = Double_field(float_rect,1); rect->width = Double_field(float_rect,2); rect->height = Double_field(float_rect,3); /* rect->left = Double_val(Field(float_rect,0)); rect->top = Double_val(Field(float_rect,1)); rect->width = Double_val(Field(float_rect,2)); rect->height = Double_val(Field(float_rect,3)); */ }
sf::FloatRect SfFloatRect_val(value float_rect) { sf::FloatRect rect; rect = sf::FloatRect( Double_field(float_rect,0), Double_field(float_rect,1), Double_field(float_rect,2), Double_field(float_rect,3)); /* rect = sf::FloatRect( Double_val(Field(float_rect,0)), Double_val(Field(float_rect,1)), Double_val(Field(float_rect,2)), Double_val(Field(float_rect,3))); */ return rect; }
void print_block(value v, int m) { int size, i; margin(m); if (Is_long(v)) { printf("immediate value (%ld)\n", Long_val(v)); return; } printf("memory block: size=%d - ", size=Wosize_val(v)); switch(Tag_val(v)) { case Closure_tag: printf("closure with %d free variables\n", size-1); margin(m+4); printf("code pointer: %p\n", Code_val(v)); for (i=1; i<size; i++) print_block(Field(v,i),m+4); break; case String_tag: printf("string: %s (%s)\n", String_val(v), (char *) v); break; case Double_tag: printf("float: %g\n", Double_val(v)); break; case Double_array_tag: printf("float array: "); for (i=0; i<size/Double_wosize; i++) printf(" %g", Double_field(v,i)); printf("\n"); break; case Abstract_tag: printf("abstract type\n"); break; case Custom_tag: printf("abstract finalized type\n"); break; default: if (Tag_val(v) >= No_scan_tag) { printf("unknown tag"); break; }; printf("structured block (tag=%d):\n", Tag_val(v)); for (i=0; i<size; i++) print_block(Field(v,i), m+4); } return; }
CAMLprim value caml_array_get_float(value array, value index) { intnat idx = Long_val(index); double d; value res; if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); d = Double_field(array, idx); Alloc_small(res, Double_wosize, Double_tag, { caml_handle_gc_interrupt(); });
CAMLprim value caml_print_array(value a) { CAMLparam1(a); int size, i; size = Wosize_val(a); for(i=0; i<size; ++i) printf("%f ", Double_field(a, i)); printf("\n"); CAMLreturn(Val_unit); }
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); }
CAMLprim value LFUN(ssqr_stub)( value vN, value vC, value vOFSX, value vINCX, value vX) { CAMLparam1(vX); integer GET_INT(N), GET_INT(INCX); VEC_PARAMS(X); COMPLEX *start, *last; COMPLEX acc = { 0.0, 0.0 }; REAL cr = Double_field(vC, 0); REAL ci = Double_field(vC, 1); REAL diffr; REAL diffi; caml_enter_blocking_section(); /* Allow other threads */ if (INCX > 0) { start = X_data; last = start + N*INCX; } else { start = X_data - (N - 1)*INCX; last = X_data + INCX; }; while (start != last) { diffr = start->r - cr; diffi = start->i - ci; acc.r += diffr * diffr - diffi * diffi; acc.i += 2 * diffr * diffi; start += INCX; }; caml_leave_blocking_section(); /* Disallow other threads */ CAMLreturn(copy_two_doubles(acc.r, acc.i)); }
value ml_gtk_curve_set_vector (value curve, value points) { guint len = Wosize_val(points) / Double_wosize; gfloat* vect = g_malloc(len * sizeof(gfloat)); int i; for (i = 0; i < len; i++) vect[i] = Double_field(points,i); gtk_curve_set_vector(GtkCurve_val(curve), len, vect); g_free(vect); return Val_unit; }
CAMLprim value caml_array_unsafe_get_float(value array, value index) { double d; value res; d = Double_field(array, Long_val(index)); #define Setup_for_gc #define Restore_after_gc Alloc_small(res, Double_wosize, Double_tag); #undef Setup_for_gc #undef Restore_after_gc Store_double_val(res, d); return res; }
CAMLprim value ml_skin_set_skel (value skel_v) { int i; size_t size; struct bone *b; struct abone *ab; CAMLparam1 (skel_v); CAMLlocal2 (v, floats_v); State *s = &glob_state; s->num_bones = Wosize_val (skel_v); size = (s->num_bones + 1) * sizeof (*b); s->bones = b = simd_alloc (16, size); s->abones = ab = simd_alloc (16, (s->num_bones + 1) * sizeof (*ab)); memset (b, 0, size); b->parent = -1; b->q[3] = 1.0; b->mq[3] = 1.0; b->aq[3] = 1.0; b->amq[3] = 1.0; b++; for (i = 0; i < s->num_bones; ++i, ++b) { v = Field (skel_v, i); floats_v = Field (v, 1); b->parent = Int_val (Field (v, 0)) + 1; b->v[0] = Double_field (floats_v, 1); b->v[1] = Double_field (floats_v, 2); b->v[2] = Double_field (floats_v, 3); b->q[0] = Double_field (floats_v, 5); b->q[1] = Double_field (floats_v, 6); b->q[2] = Double_field (floats_v, 7); b->q[3] = Double_field (floats_v, 8); } b = s->bones + 1; ab = s->abones + 1; for (i = 0; i < s->num_bones; ++i, ++b, ++ab) { float v[3]; struct bone *parent = &s->bones[b->parent]; qapply (v, parent->mq, b->v); qcompose (b->mq, b->q, parent->mq); vadd (b->mv, v, parent->mv); } CAMLreturn (Val_unit); }
CAMLprim value ml_skin_set_anim (value anim_v) { int i; CAMLparam1 (anim_v); CAMLlocal1 (floats_v); State *s = &glob_state; struct bone *b = s->bones + 1; struct abone *ab = s->abones + 1; for (i = 0; i < s->num_bones; ++i, ++b) { floats_v = Field (anim_v, i); b->aq[0] = Double_field (floats_v, 0); b->aq[1] = Double_field (floats_v, 1); b->aq[2] = Double_field (floats_v, 2); b->aq[3] = Double_field (floats_v, 3); } b = s->bones + 1; for (i = 0; i < s->num_bones; ++i, ++b, ++ab) { float v[4], v1[4], q[4], q1[4]; struct bone *parent = &s->bones[b->parent]; qapply (v, parent->amq, b->v); qcompose (b->amq, b->aq, parent->amq); vadd (b->amv, v, parent->amv); qconjugate (q1, b->mq); qcompose (q, q1, b->amq); qapply (v, q, b->mv); vsub (v1, b->amv, v); q2matrixt (ab->cm, q, v1); } CAMLreturn (Val_unit); }
CAMLprim value caml_array_get_float(value array, value index) { intnat idx = Long_val(index); double d; value res; if (idx < 0 || idx >= Wosize_val(array) / Double_wosize) caml_array_bound_error(); d = Double_field(array, idx); #define Setup_for_gc #define Restore_after_gc Alloc_small(res, Double_wosize, Double_tag); #undef Setup_for_gc #undef Restore_after_gc Store_double_val(res, d); return res; }
CAMLprim value ml_cairo_set_dash (value cr, value d, value off) { #ifndef ARCH_ALIGN_DOUBLE cairo_set_dash (cairo_t_val (cr), Double_array_val (d), Double_array_length (d), Double_val (off)); #else int i, ndash = Double_array_length (d); double *dashes = caml_stat_alloc (ndash * sizeof (double)); for (i = 0; i < ndash; i++) dashes[i] = Double_field (d, i); cairo_set_dash (cairo_t_val (cr), dashes, ndash, Double_val (off)); caml_stat_free (dashes); #endif check_cairo_status (cr); return Val_unit; }
static void set_geom (State *s, void **ptrs, value vertexa_v, value normala_v, value uva_v, value skin_v, value colors_v) { int i; float *p; int num_vertices; struct skin *skin; num_vertices = Wosize_val (vertexa_v) / (Double_wosize * 3); copy_vertices (ptrs[V_IDX], num_vertices, vertexa_v); copy_vertices (ptrs[N_IDX], num_vertices, normala_v); for (i = 0, p = ptrs[UV_IDX]; i < num_vertices * 2; ++i) { p[i] = Double_field (uva_v, i); } memcpy (ptrs[C_IDX], String_val (colors_v), num_vertices * 4); skin = s->skin; for (i = 0; i < num_vertices; ++i) { int j; value v; v = Field (skin_v, i); skin[i].boneinfo = Int_val (Field (v, 3)); for (j = 0; j < Int_val (Field (v, 3)); ++j) { double val; int boneindex; const int shifts[] = {2,12,22}; val = Double_val (Bp_val (Field (v, j))); boneindex = (int) val; skin[i].weights[j] = val - boneindex; skin[i].boneinfo |= (boneindex + 1) << shifts[j]; } } }
CAMLprim value caml_update_dummy(value dummy, value newval) { mlsize_t size, i; tag_t tag; size = Wosize_val(newval); tag = Tag_val (newval); Assert (size == Wosize_val(dummy)); Assert (tag < No_scan_tag || tag == Double_array_tag); Tag_val(dummy) = tag; if (tag == Double_array_tag){ size = Wosize_val (newval) / Double_wosize; for (i = 0; i < size; i++){ Store_double_field (dummy, i, Double_field (newval, i)); } }else{ for (i = 0; i < size; i++){ caml_modify (&Field(dummy, i), Field(newval, i)); } } return Val_unit; }
void print_value (value v, int pass, hash_table_t *ht) { int size, i, n, ret; unsigned long key; char buf[256]; addr_list_t* entry; if (Is_long(v)) { if (pass == PASS2) printf("%ld ", Long_val(v)); return; } size=Wosize_val(v); switch (Tag_val(v)) { case Closure_tag: print_closure (v, pass, ht); break; case String_tag: print_string(v); break; case Double_tag: if (pass == PASS2) printf("%g ", Double_val(v)); break; case Double_array_tag: if (pass == PASS2) { printf("[| "); n = size/Double_wosize; for (i=0; i<n; i++) { printf("%g", Double_field(v,i)); if (i < (n-1)) printf("; "); else printf(" "); } printf("|]"); } break; case Abstract_tag: if (pass == PASS2) printf("(abstract) "); break; case Custom_tag: if (pass == PASS2) printf("(custom) "); break; default: if (pass == PASS2 && Tag_val(v) >= No_scan_tag) { printf("(unknown) "); break; }; /* For structured values, PASS1 gathers information about addresses and PASS2 prints it. We use MINCYCCNT as a threshold for printing cyclic/shared values. The name of the value is just its stringified address. */ if (pass == PASS1) { key = (unsigned long)v; entry = get(ht, key); if ((entry == NULL) || (entry->count < MINCYCCNT)) { buf[0] = '\0'; sprintf(buf,"var_%lx",key); put(ht, key, strdup(buf)); } for (i=0; i<size; i++) { key = (unsigned long)Field(v,i); entry = get(ht, key); if ((entry == NULL) || (entry->count < MINCYCCNT)) print_value(Field(v,i), pass, ht); } } else if (pass == PASS2) { key = (unsigned long)v; entry = get(ht, key); if ((entry != NULL) && (entry->count >= MINCYCCNT)) { printf("(v=%s) ", entry->val); if (entry->printed == FALSE) { entry->printed = TRUE; printf("( "); for (i=0; i<size; i++) { print_value(Field(v,i), pass, ht); if (i < (size-1)) printf(", "); } printf(") "); } } else { printf("( "); for (i=0; i<size; i++) { print_value(Field(v,i), pass, ht); if (i < (size-1)) printf(", "); } printf(") "); } } } return; }
MGDesc *mgdesc_create(value ml_mg_desc) { value ml_otrans = Field(ml_mg_desc, 0), ml_copies_info = Field(ml_mg_desc, 1); size_t nr_copies = Wosize_val(ml_copies_info), nr_matrices = Wosize_val(ml_otrans), copy_idx, matrix_idx, matrix_nr_entries = DIM*DIM, matrix_size = sizeof(Real)*matrix_nr_entries; MGDesc *mg_desc = my_malloc(sizeof(MGDesc)); mg_desc->matrices = my_malloc(matrix_size*nr_matrices); mg_desc->num_copies = nr_copies; mg_desc->copies = my_malloc(sizeof(MGCopy)*nr_copies); /* Initialise the matrices */ for (matrix_idx = 0; matrix_idx < nr_matrices; matrix_idx++) { Real (*matrices)[3][3] = (Real (*)[3][3]) mg_desc->matrices, (*matrix)[3] = matrices[matrix_idx]; value ml_matrix = Field(ml_otrans, matrix_idx); size_t i, j; if (Wosize_val(ml_matrix) == DIM) { for (i = 0; i < DIM; i++) { value ml_matrix_row = Field(ml_matrix, i); if (Wosize_val(ml_matrix_row)/Double_wosize == DIM) { for (j = 0; j < DIM; j++) matrix[i][j] = Double_field(ml_matrix_row, j); } else { /* NOTE: bound checks are done only for array-s which are not guaranteed to have the right number of entry by the type system. */ mgdesc_destroy(mg_desc); raise_with_string(*caml_named_value(my_except), "Matrix row has wrong number of entries."); assert(0); } } } else { mgdesc_destroy(mg_desc); raise_with_string(*caml_named_value(my_except), "Matrix has wrong number of rows."); assert(0); } } /* Initialise the copies */ for (copy_idx = 0; copy_idx < nr_copies; copy_idx++) { MGCopy *mg_copy = & mg_desc->copies[copy_idx]; value ml_copy = Field(ml_copies_info, copy_idx); size_t nr_otrans = Int_val(Field(ml_copy, 0)); value ml_translation = Field(ml_copy, 2); /* Set the greyfactor */ mg_copy->grey_factor = Double_val(Field(ml_copy, 1)); /* Set the pointer to the transformation matrix */ if (nr_otrans < nr_matrices) { Real *the_matrix = (Real *) ((Real (*)[3][3]) mg_desc->matrices)[nr_otrans]; mg_copy->matrix = matrix_is_one(the_matrix) ? NULL : the_matrix; } else { mgdesc_destroy(mg_desc); raise_with_string(*caml_named_value(my_except), "Transformation index is out of bounds."); assert(0); } /* Set the translation vector */ if (Wosize_val(ml_translation)/Double_wosize == DIM) { size_t i; for (i = 0; i < DIM; i++) mg_copy->translation[i] = Double_field(ml_translation, i); } else { mgdesc_destroy(mg_desc); raise_with_string(*caml_named_value(my_except), "Translation vector should have dimension 3."); assert(0); } } return mg_desc; }
CAMLprim value caml_ba_fill(value vb, value vinit) { struct caml_ba_array * b = Caml_ba_array_val(vb); intnat num_elts = caml_ba_num_elts(b); switch (b->flags & CAML_BA_KIND_MASK) { default: Assert(0); case CAML_BA_FLOAT32: { float init = Double_val(vinit); float * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_FLOAT64: { double init = Double_val(vinit); double * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_SINT8: case CAML_BA_UINT8: { int init = Int_val(vinit); char * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_SINT16: case CAML_BA_UINT16: { int init = Int_val(vinit); int16 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_INT32: { int32 init = Int32_val(vinit); int32 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_INT64: { int64 init = Int64_val(vinit); int64 * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_NATIVE_INT: { intnat init = Nativeint_val(vinit); intnat * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_CAML_INT: { intnat init = Long_val(vinit); intnat * p; for (p = b->data; num_elts > 0; p++, num_elts--) *p = init; break; } case CAML_BA_COMPLEX32: { float init0 = Double_field(vinit, 0); float init1 = Double_field(vinit, 1); float * p; for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } break; } case CAML_BA_COMPLEX64: { double init0 = Double_field(vinit, 0); double init1 = Double_field(vinit, 1); double * p; for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; } break; } } return Val_unit; }
CAMLprim value wrapLALInferenceFreqDomainStudentTLogLikelihood(value options, value IFOData, value params) { CAMLparam3(options, IFOData, params); CAMLlocal4(option, nsparams, sparams, vlogL); LALPNOrder PhaseOrder=LAL_PNORDER_THREE_POINT_FIVE; LALInferenceVariables LIparams; double Mc, eta, m1, m2; double distance; double inclination, cos_i, dec; double polarization, phase, t, ra; double logL = 0.0; long nseg; double nu; LALInferenceIFOData * data = (*(LALInferenceIFOData **)Data_custom_val(IFOData)); LALInferenceIFOData *currentData = data; LIparams.dimension = 0; LIparams.head = NULL; option = Field(options, 0); nseg = Long_val(option); nu = 4.0 / M_PI * nseg; currentData = data; while (currentData != NULL) { const size_t LEN = 64; /* Comes from LALInferenceLikelihood.c */ char dofname[LEN]; snprintf(dofname, LEN, "df_%s", currentData->name); LALInferenceAddVariable(&LIparams, dofname, &nu, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_FIXED); currentData = currentData->next; } /* Extract the non-spinning parameters. */ nsparams = Field(params, 0); /* Masses. */ m1 = Double_field(nsparams, 0); m2 = Double_field(nsparams, 1); eta = m1*m2/(m1+m2)/(m1+m2); Mc = (m1+m2)*pow(eta, 3.0/5.0); LALInferenceAddVariable(&LIparams, "chirpmass", &Mc, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); LALInferenceAddVariable(&LIparams, "massratio", &eta, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); distance = Double_field(nsparams, 2); LALInferenceAddVariable(&LIparams, "distance", &distance, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); cos_i = Double_field(nsparams, 3); inclination = acos(cos_i); LALInferenceAddVariable(&LIparams, "inclination", &inclination, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); polarization = Double_field(nsparams, 4); LALInferenceAddVariable(&LIparams, "polarisation", &polarization, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR); phase = Double_field(nsparams, 5); LALInferenceAddVariable(&LIparams, "phase", &phase, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR); t = Double_field(nsparams, 6); LALInferenceAddVariable(&LIparams, "time", &t, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); ra = Double_field(nsparams, 7); LALInferenceAddVariable(&LIparams, "rightascension", &ra, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR); dec = asin(Double_field(nsparams, 8)); LALInferenceAddVariable(&LIparams, "declination", &dec, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); LALInferenceAddVariable(&LIparams, "LAL_PNORDER", &PhaseOrder, LALINFERENCE_UINT4_t, LALINFERENCE_PARAM_FIXED); if (Tag_val(params) == 0) { /* Non-spinning parameters. Run with TaylorF2 template. */ Approximant approx = TaylorF2; LALInferenceAddVariable(&LIparams, "LAL_APPROXIMANT", &approx, LALINFERENCE_UINT4_t, LALINFERENCE_PARAM_FIXED); caml_release_runtime_system(); logL = LALInferenceFreqDomainStudentTLogLikelihood(&LIparams, data, &LALInferenceTemplateLAL); caml_acquire_runtime_system(); } else { double a1, a2, costilt1, costilt2, myphi1, myphi2, theta1, theta2, phi1, phi2; Approximant approx = SpinTaylorFrameless; LALInferenceAddVariable(&LIparams, "LAL_APPROXIMANT", &approx, LALINFERENCE_UINT4_t, LALINFERENCE_PARAM_FIXED); sparams = Field(params, 1); a1 = Double_field(sparams, 0); LALInferenceAddVariable(&LIparams, "a_spin1", &a1, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); a2 = Double_field(sparams, 1); LALInferenceAddVariable(&LIparams, "a_spin2", &a2, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); costilt1 = Double_field(sparams, 2); myphi1 = Double_field(sparams, 3); theta_phi_template(&theta1, &phi1, cos_i, costilt1, myphi1); LALInferenceAddVariable(&LIparams, "theta_spin1", &theta1, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); LALInferenceAddVariable(&LIparams, "phi_spin1", &phi1, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR); costilt2 = Double_field(sparams, 4); myphi2 = Double_field(sparams, 5); theta_phi_template(&theta2, &phi2, cos_i, costilt2, myphi2); LALInferenceAddVariable(&LIparams, "theta_spin2", &theta2, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_LINEAR); LALInferenceAddVariable(&LIparams, "phi_spin2", &phi2, LALINFERENCE_REAL8_t, LALINFERENCE_PARAM_CIRCULAR); caml_release_runtime_system(); logL = LALInferenceFreqDomainStudentTLogLikelihood(&LIparams, data, &LALInferenceTemplateLALGenerateInspiral); caml_acquire_runtime_system(); } vlogL = caml_copy_double(logL); LALInferenceDestroyVariables(&LIparams); CAMLreturn(vlogL); }
void caml_debugger(enum event_kind event) { int frame_number; value * frame; intnat i, pos; value val; if (dbg_socket == -1) return; /* Not connected to a debugger. */ /* Reset current frame */ frame_number = 0; frame = caml_extern_sp + 1; /* Report the event to the debugger */ switch(event) { case PROGRAM_START: /* Nothing to report */ goto command_loop; case EVENT_COUNT: putch(dbg_out, REP_EVENT); break; case BREAKPOINT: putch(dbg_out, REP_BREAKPOINT); break; case PROGRAM_EXIT: putch(dbg_out, REP_EXITED); break; case TRAP_BARRIER: putch(dbg_out, REP_TRAP); break; case UNCAUGHT_EXC: putch(dbg_out, REP_UNCAUGHT_EXC); break; } caml_putword(dbg_out, caml_event_count); if (event == EVENT_COUNT || event == BREAKPOINT) { caml_putword(dbg_out, caml_stack_high - frame); caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); } else { /* No PC and no stack frame associated with other events */ caml_putword(dbg_out, 0); caml_putword(dbg_out, 0); } caml_flush(dbg_out); command_loop: /* Read and execute the commands sent by the debugger */ while(1) { switch(getch(dbg_in)) { case REQ_SET_EVENT: pos = caml_getword(dbg_in); Assert (pos >= 0); Assert (pos < caml_code_size); caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), EVENT); break; case REQ_SET_BREAKPOINT: pos = caml_getword(dbg_in); Assert (pos >= 0); Assert (pos < caml_code_size); caml_set_instruction(caml_start_code + pos / sizeof(opcode_t), BREAK); break; case REQ_RESET_INSTR: pos = caml_getword(dbg_in); Assert (pos >= 0); Assert (pos < caml_code_size); pos = pos / sizeof(opcode_t); caml_set_instruction(caml_start_code + pos, caml_saved_code[pos]); break; case REQ_CHECKPOINT: #ifndef _WIN32 i = fork(); if (i == 0) { close_connection(); /* Close parent connection. */ open_connection(); /* Open new connection with debugger */ } else { caml_putword(dbg_out, i); caml_flush(dbg_out); } #else caml_fatal_error("error: REQ_CHECKPOINT command"); exit(-1); #endif break; case REQ_GO: caml_event_count = caml_getword(dbg_in); return; case REQ_STOP: exit(0); break; case REQ_WAIT: #ifndef _WIN32 wait(NULL); #else caml_fatal_error("Fatal error: REQ_WAIT command"); exit(-1); #endif break; case REQ_INITIAL_FRAME: frame = caml_extern_sp + 1; /* Fall through */ case REQ_GET_FRAME: caml_putword(dbg_out, caml_stack_high - frame); if (frame < caml_stack_high){ caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); }else{ caml_putword (dbg_out, 0); } caml_flush(dbg_out); break; case REQ_SET_FRAME: i = caml_getword(dbg_in); frame = caml_stack_high - i; break; case REQ_UP_FRAME: i = caml_getword(dbg_in); if (frame + Extra_args(frame) + i + 3 >= caml_stack_high) { caml_putword(dbg_out, -1); } else { frame += Extra_args(frame) + i + 3; caml_putword(dbg_out, caml_stack_high - frame); caml_putword(dbg_out, (Pc(frame) - caml_start_code) * sizeof(opcode_t)); } caml_flush(dbg_out); break; case REQ_SET_TRAP_BARRIER: i = caml_getword(dbg_in); caml_trap_barrier = caml_stack_high - i; break; case REQ_GET_LOCAL: i = caml_getword(dbg_in); putval(dbg_out, Locals(frame)[i]); caml_flush(dbg_out); break; case REQ_GET_ENVIRONMENT: i = caml_getword(dbg_in); putval(dbg_out, Field(Env(frame), i)); caml_flush(dbg_out); break; case REQ_GET_GLOBAL: i = caml_getword(dbg_in); putval(dbg_out, Field(caml_global_data, i)); caml_flush(dbg_out); break; case REQ_GET_ACCU: putval(dbg_out, *caml_extern_sp); caml_flush(dbg_out); break; case REQ_GET_HEADER: val = getval(dbg_in); caml_putword(dbg_out, Hd_val(val)); caml_flush(dbg_out); break; case REQ_GET_FIELD: val = getval(dbg_in); i = caml_getword(dbg_in); if (Tag_val(val) != Double_array_tag) { putch(dbg_out, 0); putval(dbg_out, Field(val, i)); } else { double d = Double_field(val, i); putch(dbg_out, 1); caml_really_putblock(dbg_out, (char *) &d, 8); } caml_flush(dbg_out); break; case REQ_MARSHAL_OBJ: val = getval(dbg_in); safe_output_value(dbg_out, val); caml_flush(dbg_out); break; case REQ_GET_CLOSURE_CODE: val = getval(dbg_in); caml_putword(dbg_out, (Code_val(val)-caml_start_code) * sizeof(opcode_t)); caml_flush(dbg_out); break; case REQ_SET_FORK_MODE: caml_debugger_fork_mode = caml_getword(dbg_in); break; } } }
static intnat compare_val(value v1, value v2, int total) { struct compare_item * sp; tag_t t1, t2; if (!compare_stack) compare_init_stack(); sp = compare_stack; while (1) { if (v1 == v2 && total) goto next_item; if (Is_long(v1)) { if (v1 == v2) goto next_item; if (Is_long(v2)) return Long_val(v1) - Long_val(v2); /* Subtraction above cannot overflow and cannot result in UNORDERED */ switch (Tag_val(v2)) { case Forward_tag: v2 = Forward_val(v2); continue; case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v2)->compare_ext; if (compare == NULL) break; /* for backward compatibility */ caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; goto next_item; } default: /*fallthrough*/; } return LESS; /* v1 long < v2 block */ } if (Is_long(v2)) { switch (Tag_val(v1)) { case Forward_tag: v1 = Forward_val(v1); continue; case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare_ext; if (compare == NULL) break; /* for backward compatibility */ caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; goto next_item; } default: /*fallthrough*/; } return GREATER; /* v1 block > v2 long */ } t1 = Tag_val(v1); t2 = Tag_val(v2); if (t1 == Forward_tag) { v1 = Forward_val (v1); continue; } if (t2 == Forward_tag) { v2 = Forward_val (v2); continue; } if (t1 != t2) return (intnat)t1 - (intnat)t2; switch(t1) { case String_tag: { mlsize_t len1, len2; int res; if (v1 == v2) break; len1 = caml_string_length(v1); len2 = caml_string_length(v2); res = memcmp(String_val(v1), String_val(v2), len1 <= len2 ? len1 : len2); if (res < 0) return LESS; if (res > 0) return GREATER; if (len1 != len2) return len1 - len2; break; } case Double_tag: { double d1 = Double_val(v1); double d2 = Double_val(v2); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; /* One or both of d1 and d2 is NaN. Order according to the convention NaN = NaN and NaN < f for all other floats f. */ if (d1 == d1) return GREATER; /* d1 is not NaN, d2 is NaN */ if (d2 == d2) return LESS; /* d2 is not NaN, d1 is NaN */ /* d1 and d2 are both NaN, thus equal: continue comparison */ } break; } case Double_array_tag: { mlsize_t sz1 = Wosize_val(v1) / Double_wosize; mlsize_t sz2 = Wosize_val(v2) / Double_wosize; mlsize_t i; if (sz1 != sz2) return sz1 - sz2; for (i = 0; i < sz1; i++) { double d1 = Double_field(v1, i); double d2 = Double_field(v2, i); if (d1 < d2) return LESS; if (d1 > d2) return GREATER; if (d1 != d2) { if (! total) return UNORDERED; /* See comment for Double_tag case */ if (d1 == d1) return GREATER; if (d2 == d2) return LESS; } } break; } case Abstract_tag: compare_free_stack(); caml_invalid_argument("equal: abstract value"); case Closure_tag: case Infix_tag: compare_free_stack(); caml_invalid_argument("equal: functional value"); case Object_tag: { intnat oid1 = Oid_val(v1); intnat oid2 = Oid_val(v2); if (oid1 != oid2) return oid1 - oid2; break; } case Custom_tag: { int res; int (*compare)(value v1, value v2) = Custom_ops_val(v1)->compare; /* Hardening against comparisons between different types */ if (compare != Custom_ops_val(v2)->compare) { return strcmp(Custom_ops_val(v1)->identifier, Custom_ops_val(v2)->identifier) < 0 ? LESS : GREATER; } if (compare == NULL) { compare_free_stack(); caml_invalid_argument("equal: abstract value"); } caml_compare_unordered = 0; res = compare(v1, v2); if (caml_compare_unordered && !total) return UNORDERED; if (res != 0) return res; break; } default: { mlsize_t sz1 = Wosize_val(v1); mlsize_t sz2 = Wosize_val(v2); /* Compare sizes first for speed */ if (sz1 != sz2) return sz1 - sz2; if (sz1 == 0) break; /* Remember that we still have to compare fields 1 ... sz - 1 */ if (sz1 > 1) { sp++; if (sp >= compare_stack_limit) sp = compare_resize_stack(sp); sp->v1 = Op_val(v1) + 1; sp->v2 = Op_val(v2) + 1; sp->count = sz1 - 1; } /* Continue comparison with first field */ v1 = Field(v1, 0); v2 = Field(v2, 0); continue; } } next_item: /* Pop one more item to compare, if any */ if (sp == compare_stack) return EQUAL; /* we're done */ v1 = *((sp->v1)++); v2 = *((sp->v2)++); if (--(sp->count) == 0) sp--; } }