CAMLprim value caml_ba_reshape(value vb, value vdim)
{
CAMLparam2 (vb, vdim);
CAMLlocal1 (res);
#define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
intnat dim[CAML_BA_MAX_NUM_DIMS];
mlsize_t num_dims;
uintnat num_elts;
int i;
num_dims = Wosize_val(vdim);
if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
caml_invalid_argument("Bigarray.reshape: bad number of dimensions");
num_elts = 1;
for (i = 0; i < num_dims; i++) {
dim[i] = Long_val(Field(vdim, i));
if (dim[i] < 0)
caml_invalid_argument("Bigarray.reshape: negative dimension");
num_elts *= dim[i];
}
/* Check that sizes agree */
if (num_elts != caml_ba_num_elts(b))
caml_invalid_argument("Bigarray.reshape: size mismatch");
/* Create bigarray with same data and new dimensions */
res = caml_ba_alloc(b->flags, num_dims, b->data, dim);
/* Create or update proxy in case of managed bigarray */
caml_ba_update_proxy(b, Caml_ba_array_val(res));
/* Return result */
CAMLreturn (res);
#undef b
}
uintnat caml_ba_deserialize(void * dst)
{
struct caml_ba_array * b = dst;
int i, elt_size;
uintnat num_elts;
/* Read back header information */
b->num_dims = caml_deserialize_uint_4();
b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
b->proxy = NULL;
for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
/* Compute total number of elements */
num_elts = caml_ba_num_elts(b);
/* Determine element size in bytes */
#ifdef _KERNEL
if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_NATIVE_INT)
#else
if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_COMPLEX64)
#endif
caml_deserialize_error("input_value: bad bigarray kind");
elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
/* Allocate room for data */
b->data = __malloc(elt_size * num_elts);
if (b->data == NULL)
caml_deserialize_error("input_value: out of memory for bigarray");
/* Read data */
switch (b->flags & CAML_BA_KIND_MASK) {
case CAML_BA_SINT8:
case CAML_BA_UINT8:
caml_deserialize_block_1(b->data, num_elts); break;
case CAML_BA_SINT16:
case CAML_BA_UINT16:
caml_deserialize_block_2(b->data, num_elts); break;
#ifdef _KERNEL
#else
case CAML_BA_FLOAT32:
#endif
case CAML_BA_INT32:
caml_deserialize_block_4(b->data, num_elts); break;
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX32:
caml_deserialize_block_4(b->data, num_elts * 2); break;
case CAML_BA_FLOAT64:
#endif
case CAML_BA_INT64:
caml_deserialize_block_8(b->data, num_elts); break;
#ifdef _KERNEL
#else
case CAML_BA_COMPLEX64:
caml_deserialize_block_8(b->data, num_elts * 2); break;
#endif
case CAML_BA_CAML_INT:
case CAML_BA_NATIVE_INT:
caml_ba_deserialize_longarray(b->data, num_elts); break;
}
return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat);
}
CAMLexport uintnat caml_ba_deserialize(void * dst)
{
struct caml_ba_array * b = dst;
int i, elt_size;
uintnat num_elts;
/* Read back header information */
b->num_dims = caml_deserialize_uint_4();
b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
b->proxy = NULL;
for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
/* Compute total number of elements */
num_elts = caml_ba_num_elts(b);
/* Determine element size in bytes */
if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_CHAR)
caml_deserialize_error("input_value: bad bigarray kind");
elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
/* Allocate room for data */
b->data = malloc(elt_size * num_elts);
if (b->data == NULL)
caml_deserialize_error("input_value: out of memory for bigarray");
/* Read data */
switch (b->flags & CAML_BA_KIND_MASK) {
case CAML_BA_CHAR:
case CAML_BA_SINT8:
case CAML_BA_UINT8:
caml_deserialize_block_1(b->data, num_elts); break;
case CAML_BA_SINT16:
case CAML_BA_UINT16:
caml_deserialize_block_2(b->data, num_elts); break;
case CAML_BA_FLOAT32:
case CAML_BA_INT32:
caml_deserialize_block_4(b->data, num_elts); break;
case CAML_BA_COMPLEX32:
caml_deserialize_block_4(b->data, num_elts * 2); break;
case CAML_BA_FLOAT64:
case CAML_BA_INT64:
caml_deserialize_block_8(b->data, num_elts); break;
case CAML_BA_COMPLEX64:
caml_deserialize_block_8(b->data, num_elts * 2); break;
case CAML_BA_CAML_INT:
case CAML_BA_NATIVE_INT:
caml_ba_deserialize_longarray(b->data, num_elts); break;
}
/* PR#5516: use C99's flexible array types if possible */
return SIZEOF_BA_ARRAY + b->num_dims * sizeof(intnat);
}
CAMLprim value caml_ba_blit(value vsrc, value vdst)
{
struct caml_ba_array * src = Caml_ba_array_val(vsrc);
struct caml_ba_array * dst = Caml_ba_array_val(vdst);
int i;
intnat num_bytes;
/* Check same numbers of dimensions and same dimensions */
if (src->num_dims != dst->num_dims) goto blit_error;
for (i = 0; i < src->num_dims; i++)
if (src->dim[i] != dst->dim[i]) goto blit_error;
/* Compute number of bytes in array data */
num_bytes =
caml_ba_num_elts(src)
* caml_ba_element_size[src->flags & CAML_BA_KIND_MASK];
/* Do the copying */
memmove (dst->data, src->data, num_bytes);
return Val_unit;
blit_error:
caml_invalid_argument("Bigarray.blit: dimension mismatch");
return Val_unit; /* not reached */
}
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;
}
CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b)
{
return caml_ba_num_elts(b)
* caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
}
static int caml_ba_compare(value v1, value v2)
{
struct caml_ba_array * b1 = Caml_ba_array_val(v1);
struct caml_ba_array * b2 = Caml_ba_array_val(v2);
uintnat n, num_elts;
intnat flags1, flags2;
int i;
/* Compare kind & layout in case the arguments are of different types */
flags1 = b1->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
flags2 = b2->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK);
if (flags1 != flags2) return flags2 - flags1;
/* Compare number of dimensions */
if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims;
/* Same number of dimensions: compare dimensions lexicographically */
for (i = 0; i < b1->num_dims; i++) {
intnat d1 = b1->dim[i];
intnat d2 = b2->dim[i];
if (d1 != d2) return d1 < d2 ? -1 : 1;
}
/* Same dimensions: compare contents lexicographically */
num_elts = caml_ba_num_elts(b1);
#define DO_INTEGER_COMPARISON(type) \
{ type * p1 = b1->data; type * p2 = b2->data; \
for (n = 0; n < num_elts; n++) { \
type e1 = *p1++; type e2 = *p2++; \
if (e1 < e2) return -1; \
if (e1 > e2) return 1; \
} \
return 0; \
}
#define DO_FLOAT_COMPARISON(type) \
{ type * p1 = b1->data; type * p2 = b2->data; \
for (n = 0; n < num_elts; n++) { \
type e1 = *p1++; type e2 = *p2++; \
if (e1 < e2) return -1; \
if (e1 > e2) return 1; \
if (e1 != e2) { \
caml_compare_unordered = 1; \
if (e1 == e1) return 1; \
if (e2 == e2) return -1; \
} \
} \
return 0; \
}
switch (b1->flags & CAML_BA_KIND_MASK) {
case CAML_BA_COMPLEX32:
num_elts *= 2; /*fallthrough*/
case CAML_BA_FLOAT32:
DO_FLOAT_COMPARISON(float);
case CAML_BA_COMPLEX64:
num_elts *= 2; /*fallthrough*/
case CAML_BA_FLOAT64:
DO_FLOAT_COMPARISON(double);
case CAML_BA_SINT8:
DO_INTEGER_COMPARISON(int8);
case CAML_BA_UINT8:
DO_INTEGER_COMPARISON(uint8);
case CAML_BA_SINT16:
DO_INTEGER_COMPARISON(int16);
case CAML_BA_UINT16:
DO_INTEGER_COMPARISON(uint16);
case CAML_BA_INT32:
DO_INTEGER_COMPARISON(int32);
case CAML_BA_INT64:
#ifdef ARCH_INT64_TYPE
DO_INTEGER_COMPARISON(int64);
#else
{ int64 * p1 = b1->data; int64 * p2 = b2->data;
for (n = 0; n < num_elts; n++) {
int64 e1 = *p1++; int64 e2 = *p2++;
if ((int32)e1.h > (int32)e2.h) return 1;
if ((int32)e1.h < (int32)e2.h) return -1;
if (e1.l > e2.l) return 1;
if (e1.l < e2.l) return -1;
}
return 0;
}
#endif
case CAML_BA_CAML_INT:
case CAML_BA_NATIVE_INT:
DO_INTEGER_COMPARISON(intnat);
default:
Assert(0);
return 0; /* should not happen */
}
#undef DO_INTEGER_COMPARISON
#undef DO_FLOAT_COMPARISON
}
