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--;
}
}
