l4/pkg/ocaml/ocaml/contrib/otherlibs/bigarray/bigarray_stubs.c

   1 /***********************************************************************/
   2 /*                                                                     */
   3 /*                           Objective Caml                            */
   4 /*                                                                     */
   5 /*         Manuel Serrano and Xavier Leroy, INRIA Rocquencourt         */
   6 /*                                                                     */
   7 /*  Copyright 2000 Institut National de Recherche en Informatique et   */
   8 /*  en Automatique.  All rights reserved.  This file is distributed    */
   9 /*  under the terms of the GNU Library General Public License, with    */
  10 /*  the special exception on linking described in file ../../LICENSE.  */
  11 /*                                                                     */
  12 /***********************************************************************/
  13
  14 /* $Id: bigarray_stubs.c 9123 2008-11-09 09:03:51Z xleroy $ */
  15
  16 #include <stddef.h>
  17 #include <stdarg.h>
  18 #include <string.h>
  19 #include "alloc.h"
  20 #include "bigarray.h"
  21 #include "custom.h"
  22 #include "fail.h"
  23 #include "intext.h"
  24 #include "memory.h"
  25 #include "mlvalues.h"
  26
  27 #define int8 caml_ba_int8
  28 #define uint8 caml_ba_uint8
  29 #define int16 caml_ba_int16
  30 #define uint16 caml_ba_uint16
  31
  32 extern void caml_ba_unmap_file(void * addr, uintnat len);
  33                                           /* from mmap_xxx.c */
  34
  35 /* Compute the number of elements of a big array */
  36
  37 static uintnat caml_ba_num_elts(struct caml_ba_array * b)
  38 {
  39   uintnat num_elts;
  40   int i;
  41   num_elts = 1;
  42   for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
  43   return num_elts;
  44 }
  45
  46 /* Size in bytes of a bigarray element, indexed by bigarray kind */
  47
  48 int caml_ba_element_size[] =
  49 { 4 /*FLOAT32*/, 8 /*FLOAT64*/,
  50   1 /*SINT8*/, 1 /*UINT8*/,
  51   2 /*SINT16*/, 2 /*UINT16*/,
  52   4 /*INT32*/, 8 /*INT64*/,
  53   sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/,
  54   8 /*COMPLEX32*/, 16 /*COMPLEX64*/
  55 };
  56
  57 /* Compute the number of bytes for the elements of a big array */
  58
  59 CAMLexport uintnat caml_ba_byte_size(struct caml_ba_array * b)
  60 {
  61   return caml_ba_num_elts(b)
  62          * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
  63 }
  64
  65 /* Operation table for bigarrays */
  66
  67 static void caml_ba_finalize(value v);
  68 static int caml_ba_compare(value v1, value v2);
  69 static intnat caml_ba_hash(value v);
  70 static void caml_ba_serialize(value, uintnat *, uintnat *);
  71 uintnat caml_ba_deserialize(void * dst);
  72 static struct custom_operations caml_ba_ops = {
  73   "_bigarray",
  74   caml_ba_finalize,
  75   caml_ba_compare,
  76   caml_ba_hash,
  77   caml_ba_serialize,
  78   caml_ba_deserialize
  79 };
  80
  81 /* Multiplication of unsigned longs with overflow detection */
  82
  83 static uintnat
  84 caml_ba_multov(uintnat a, uintnat b, int * overflow)
  85 {
  86 #define HALF_SIZE (sizeof(uintnat) * 4)
  87 #define HALF_MASK (((uintnat)1 << HALF_SIZE) - 1)
  88 #define LOW_HALF(x) ((x) & HALF_MASK)
  89 #define HIGH_HALF(x) ((x) >> HALF_SIZE)
  90   /* Cut in half words */
  91   uintnat al = LOW_HALF(a);
  92   uintnat ah = HIGH_HALF(a);
  93   uintnat bl = LOW_HALF(b);
  94   uintnat bh = HIGH_HALF(b);
  95   /* Exact product is:
  96               al * bl
  97            +  ah * bl  << HALF_SIZE
  98            +  al * bh  << HALF_SIZE
  99            +  ah * bh  << 2*HALF_SIZE
 100      Overflow occurs if:
 101         ah * bh is not 0, i.e. ah != 0 and bh != 0
 102      OR ah * bl has high half != 0
 103      OR ah * bl has high half != 0
 104      OR the sum al * bl + LOW_HALF(ah * bl) << HALF_SIZE
 105                         + LOW_HALF(al * bh) << HALF_SIZE overflows.
 106      This sum is equal to p = (a * b) modulo word size. */
 107   uintnat p1 = al * bh;
 108   uintnat p2 = ah * bl;
 109   uintnat p = a * b;
 110   if (ah != 0 && bh != 0) *overflow = 1;
 111   if (HIGH_HALF(p1) != 0 || HIGH_HALF(p2) != 0) *overflow = 1;
 112   p1 <<= HALF_SIZE;
 113   p2 <<= HALF_SIZE;
 114   p1 += p2;
 115   if (p < p1 || p1 < p2) *overflow = 1; /* overflow in sums */
 116   return p;
 117 #undef HALF_SIZE
 118 #undef LOW_HALF
 119 #undef HIGH_HALF
 120 }
 121
 122 /* Allocation of a big array */
 123
 124 #define CAML_BA_MAX_MEMORY 256*1024*1024
 125 /* 256 Mb -- after allocating that much, it's probably worth speeding
 126    up the major GC */
 127
 128 /* [caml_ba_alloc] will allocate a new bigarray object in the heap.
 129    If [data] is NULL, the memory for the contents is also allocated
 130    (with [malloc]) by [caml_ba_alloc].
 131    [data] cannot point into the Caml heap.
 132    [dim] may point into an object in the Caml heap.
 133 */
 134 CAMLexport value
 135 caml_ba_alloc(int flags, int num_dims, void * data, intnat * dim)
 136 {
 137   uintnat num_elts, size;
 138   int overflow, i;
 139   value res;
 140   struct caml_ba_array * b;
 141   intnat dimcopy[CAML_BA_MAX_NUM_DIMS];
 142
 143   Assert(num_dims >= 1 && num_dims <= CAML_BA_MAX_NUM_DIMS);
 144   Assert((flags & CAML_BA_KIND_MASK) <= CAML_BA_COMPLEX64);
 145   for (i = 0; i < num_dims; i++) dimcopy[i] = dim[i];
 146   size = 0;
 147   if (data == NULL) {
 148     overflow = 0;
 149     num_elts = 1;
 150     for (i = 0; i < num_dims; i++) {
 151       num_elts = caml_ba_multov(num_elts, dimcopy[i], &overflow);
 152     }
 153     size = caml_ba_multov(num_elts,
 154                           caml_ba_element_size[flags & CAML_BA_KIND_MASK],
 155                           &overflow);
 156     if (overflow) caml_raise_out_of_memory();
 157     data = malloc(size);
 158     if (data == NULL && size != 0) caml_raise_out_of_memory();
 159     flags |= CAML_BA_MANAGED;
 160   }
 161   res = caml_alloc_custom(&caml_ba_ops,
 162                           sizeof(struct caml_ba_array)
 163                           + (num_dims - 1) * sizeof(intnat),
 164                           size, CAML_BA_MAX_MEMORY);
 165   b = Caml_ba_array_val(res);
 166   b->data = data;
 167   b->num_dims = num_dims;
 168   b->flags = flags;
 169   b->proxy = NULL;
 170   for (i = 0; i < num_dims; i++) b->dim[i] = dimcopy[i];
 171   return res;
 172 }
 173
 174 /* Same as caml_ba_alloc, but dimensions are passed as a list of
 175    arguments */
 176
 177 CAMLexport value caml_ba_alloc_dims(int flags, int num_dims, void * data, ...)
 178 {
 179   va_list ap;
 180   intnat dim[CAML_BA_MAX_NUM_DIMS];
 181   int i;
 182   value res;
 183
 184   va_start(ap, data);
 185   for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, intnat);
 186   va_end(ap);
 187   res = caml_ba_alloc(flags, num_dims, data, dim);
 188   return res;
 189 }
 190
 191 /* Allocate a bigarray from Caml */
 192
 193 CAMLprim value caml_ba_create(value vkind, value vlayout, value vdim)
 194 {
 195   intnat dim[CAML_BA_MAX_NUM_DIMS];
 196   mlsize_t num_dims;
 197   int i, flags;
 198
 199   num_dims = Wosize_val(vdim);
 200   if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
 201     caml_invalid_argument("Bigarray.create: bad number of dimensions");
 202   for (i = 0; i < num_dims; i++) {
 203     dim[i] = Long_val(Field(vdim, i));
 204     if (dim[i] < 0)
 205       caml_invalid_argument("Bigarray.create: negative dimension");
 206   }
 207   flags = Int_val(vkind) | Int_val(vlayout);
 208   return caml_ba_alloc(flags, num_dims, NULL, dim);
 209 }
 210
 211 /* Given a big array and a vector of indices, check that the indices
 212    are within the bounds and return the offset of the corresponding
 213    array element in the data part of the array. */
 214
 215 static long caml_ba_offset(struct caml_ba_array * b, intnat * index)
 216 {
 217   intnat offset;
 218   int i;
 219
 220   offset = 0;
 221   if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
 222     /* C-style layout: row major, indices start at 0 */
 223     for (i = 0; i < b->num_dims; i++) {
 224       if ((uintnat) index[i] >= (uintnat) b->dim[i])
 225         caml_array_bound_error();
 226       offset = offset * b->dim[i] + index[i];
 227     }
 228   } else {
 229     /* Fortran-style layout: column major, indices start at 1 */
 230     for (i = b->num_dims - 1; i >= 0; i--) {
 231       if ((uintnat) (index[i] - 1) >= (uintnat) b->dim[i])
 232         caml_array_bound_error();
 233       offset = offset * b->dim[i] + (index[i] - 1);
 234     }
 235   }
 236   return offset;
 237 }
 238
 239 /* Helper function to allocate a record of two double floats */
 240
 241 static value copy_two_doubles(double d0, double d1)
 242 {
 243   value res = caml_alloc_small(2 * Double_wosize, Double_array_tag);
 244   Store_double_field(res, 0, d0);
 245   Store_double_field(res, 1, d1);
 246   return res;
 247 }
 248
 249 /* Generic code to read from a big array */
 250
 251 value caml_ba_get_N(value vb, value * vind, int nind)
 252 {
 253   struct caml_ba_array * b = Caml_ba_array_val(vb);
 254   intnat index[CAML_BA_MAX_NUM_DIMS];
 255   int i;
 256   intnat offset;
 257
 258   /* Check number of indices = number of dimensions of array
 259      (maybe not necessary if ML typing guarantees this) */
 260   if (nind != b->num_dims)
 261     caml_invalid_argument("Bigarray.get: wrong number of indices");
 262   /* Compute offset and check bounds */
 263   for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
 264   offset = caml_ba_offset(b, index);
 265   /* Perform read */
 266   switch ((b->flags) & CAML_BA_KIND_MASK) {
 267   default:
 268     Assert(0);
 269   case CAML_BA_FLOAT32:
 270     return caml_copy_double(((float *) b->data)[offset]);
 271   case CAML_BA_FLOAT64:
 272     return caml_copy_double(((double *) b->data)[offset]);
 273   case CAML_BA_SINT8:
 274     return Val_int(((int8 *) b->data)[offset]);
 275   case CAML_BA_UINT8:
 276     return Val_int(((uint8 *) b->data)[offset]);
 277   case CAML_BA_SINT16:
 278     return Val_int(((int16 *) b->data)[offset]);
 279   case CAML_BA_UINT16:
 280     return Val_int(((uint16 *) b->data)[offset]);
 281   case CAML_BA_INT32:
 282     return caml_copy_int32(((int32 *) b->data)[offset]);
 283   case CAML_BA_INT64:
 284     return caml_copy_int64(((int64 *) b->data)[offset]);
 285   case CAML_BA_NATIVE_INT:
 286     return caml_copy_nativeint(((intnat *) b->data)[offset]);
 287   case CAML_BA_CAML_INT:
 288     return Val_long(((intnat *) b->data)[offset]);
 289   case CAML_BA_COMPLEX32:
 290     { float * p = ((float *) b->data) + offset * 2;
 291       return copy_two_doubles(p[0], p[1]); }
 292   case CAML_BA_COMPLEX64:
 293     { double * p = ((double *) b->data) + offset * 2;
 294       return copy_two_doubles(p[0], p[1]); }
 295   }
 296 }
 297
 298 CAMLprim value caml_ba_get_1(value vb, value vind1)
 299 {
 300   return caml_ba_get_N(vb, &vind1, 1);
 301 }
 302
 303 CAMLprim value caml_ba_get_2(value vb, value vind1, value vind2)
 304 {
 305   value vind[2];
 306   vind[0] = vind1; vind[1] = vind2;
 307   return caml_ba_get_N(vb, vind, 2);
 308 }
 309
 310 CAMLprim value caml_ba_get_3(value vb, value vind1, value vind2, value vind3)
 311 {
 312   value vind[3];
 313   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
 314   return caml_ba_get_N(vb, vind, 3);
 315 }
 316
 317 #if 0
 318 CAMLprim value caml_ba_get_4(value vb, value vind1, value vind2,
 319                      value vind3, value vind4)
 320 {
 321   value vind[4];
 322   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
 323   return caml_ba_get_N(vb, vind, 4);
 324 }
 325
 326 CAMLprim value caml_ba_get_5(value vb, value vind1, value vind2,
 327                      value vind3, value vind4, value vind5)
 328 {
 329   value vind[5];
 330   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
 331   vind[3] = vind4; vind[4] = vind5;
 332   return caml_ba_get_N(vb, vind, 5);
 333 }
 334
 335 CAMLprim value caml_ba_get_6(value vb, value vind1, value vind2,
 336                      value vind3, value vind4, value vind5, value vind6)
 337 {
 338   value vind[6];
 339   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
 340   vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
 341   return caml_ba_get_N(vb, vind, 6);
 342 }
 343 #endif
 344
 345 CAMLprim value caml_ba_get_generic(value vb, value vind)
 346 {
 347   return caml_ba_get_N(vb, &Field(vind, 0), Wosize_val(vind));
 348 }
 349
 350 /* Generic write to a big array */
 351
 352 static value caml_ba_set_aux(value vb, value * vind, intnat nind, value newval)
 353 {
 354   struct caml_ba_array * b = Caml_ba_array_val(vb);
 355   intnat index[CAML_BA_MAX_NUM_DIMS];
 356   int i;
 357   intnat offset;
 358
 359   /* Check number of indices = number of dimensions of array
 360      (maybe not necessary if ML typing guarantees this) */
 361   if (nind != b->num_dims)
 362     caml_invalid_argument("Bigarray.set: wrong number of indices");
 363   /* Compute offset and check bounds */
 364   for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
 365   offset = caml_ba_offset(b, index);
 366   /* Perform write */
 367   switch (b->flags & CAML_BA_KIND_MASK) {
 368   default:
 369     Assert(0);
 370   case CAML_BA_FLOAT32:
 371     ((float *) b->data)[offset] = Double_val(newval); break;
 372   case CAML_BA_FLOAT64:
 373     ((double *) b->data)[offset] = Double_val(newval); break;
 374   case CAML_BA_SINT8:
 375   case CAML_BA_UINT8:
 376     ((int8 *) b->data)[offset] = Int_val(newval); break;
 377   case CAML_BA_SINT16:
 378   case CAML_BA_UINT16:
 379     ((int16 *) b->data)[offset] = Int_val(newval); break;
 380   case CAML_BA_INT32:
 381     ((int32 *) b->data)[offset] = Int32_val(newval); break;
 382   case CAML_BA_INT64:
 383     ((int64 *) b->data)[offset] = Int64_val(newval); break;
 384   case CAML_BA_NATIVE_INT:
 385     ((intnat *) b->data)[offset] = Nativeint_val(newval); break;
 386   case CAML_BA_CAML_INT:
 387     ((intnat *) b->data)[offset] = Long_val(newval); break;
 388   case CAML_BA_COMPLEX32:
 389     { float * p = ((float *) b->data) + offset * 2;
 390       p[0] = Double_field(newval, 0);
 391       p[1] = Double_field(newval, 1);
 392       break; }
 393   case CAML_BA_COMPLEX64:
 394     { double * p = ((double *) b->data) + offset * 2;
 395       p[0] = Double_field(newval, 0);
 396       p[1] = Double_field(newval, 1);
 397       break; }
 398   }
 399   return Val_unit;
 400 }
 401
 402 CAMLprim value caml_ba_set_1(value vb, value vind1, value newval)
 403 {
 404   return caml_ba_set_aux(vb, &vind1, 1, newval);
 405 }
 406
 407 CAMLprim value caml_ba_set_2(value vb, value vind1, value vind2, value newval)
 408 {
 409   value vind[2];
 410   vind[0] = vind1; vind[1] = vind2;
 411   return caml_ba_set_aux(vb, vind, 2, newval);
 412 }
 413
 414 CAMLprim value caml_ba_set_3(value vb, value vind1, value vind2, value vind3,
 415                      value newval)
 416 {
 417   value vind[3];
 418   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
 419   return caml_ba_set_aux(vb, vind, 3, newval);
 420 }
 421
 422 #if 0
 423 CAMLprim value caml_ba_set_4(value vb, value vind1, value vind2,
 424                      value vind3, value vind4, value newval)
 425 {
 426   value vind[4];
 427   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
 428   return caml_ba_set_aux(vb, vind, 4, newval);
 429 }
 430
 431 CAMLprim value caml_ba_set_5(value vb, value vind1, value vind2,
 432                      value vind3, value vind4, value vind5, value newval)
 433 {
 434   value vind[5];
 435   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
 436   vind[3] = vind4; vind[4] = vind5;
 437   return caml_ba_set_aux(vb, vind, 5, newval);
 438 }
 439
 440 CAMLprim value caml_ba_set_6(value vb, value vind1, value vind2,
 441                      value vind3, value vind4, value vind5,
 442                      value vind6, value newval)
 443 {
 444   value vind[6];
 445   vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
 446   vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
 447   return caml_ba_set_aux(vb, vind, 6, newval);
 448 }
 449
 450 value caml_ba_set_N(value vb, value * vind, int nargs)
 451 {
 452   return caml_ba_set_aux(vb, vind, nargs - 1, vind[nargs - 1]);
 453 }
 454 #endif
 455
 456 CAMLprim value caml_ba_set_generic(value vb, value vind, value newval)
 457 {
 458   return caml_ba_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
 459 }
 460
 461 /* Return the number of dimensions of a big array */
 462
 463 CAMLprim value caml_ba_num_dims(value vb)
 464 {
 465   struct caml_ba_array * b = Caml_ba_array_val(vb);
 466   return Val_long(b->num_dims);
 467 }
 468
 469 /* Return the n-th dimension of a big array */
 470
 471 CAMLprim value caml_ba_dim(value vb, value vn)
 472 {
 473   struct caml_ba_array * b = Caml_ba_array_val(vb);
 474   intnat n = Long_val(vn);
 475   if (n >= b->num_dims) caml_invalid_argument("Bigarray.dim");
 476   return Val_long(b->dim[n]);
 477 }
 478
 479 /* Return the kind of a big array */
 480
 481 CAMLprim value caml_ba_kind(value vb)
 482 {
 483   return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_KIND_MASK);
 484 }
 485
 486 /* Return the layout of a big array */
 487
 488 CAMLprim value caml_ba_layout(value vb)
 489 {
 490   return Val_int(Caml_ba_array_val(vb)->flags & CAML_BA_LAYOUT_MASK);
 491 }
 492
 493 /* Finalization of a big array */
 494
 495 static void caml_ba_finalize(value v)
 496 {
 497   struct caml_ba_array * b = Caml_ba_array_val(v);
 498
 499   switch (b->flags & CAML_BA_MANAGED_MASK) {
 500   case CAML_BA_EXTERNAL:
 501     break;
 502   case CAML_BA_MANAGED:
 503     if (b->proxy == NULL) {
 504       free(b->data);
 505     } else {
 506       if (-- b->proxy->refcount == 0) {
 507         free(b->proxy->data);
 508         caml_stat_free(b->proxy);
 509       }
 510     }
 511     break;
 512   case CAML_BA_MAPPED_FILE:
 513     if (b->proxy == NULL) {
 514       caml_ba_unmap_file(b->data, caml_ba_byte_size(b));
 515     } else {
 516       if (-- b->proxy->refcount == 0) {
 517         caml_ba_unmap_file(b->proxy->data, b->proxy->size);
 518         caml_stat_free(b->proxy);
 519       }
 520     }
 521     break;
 522   }
 523 }
 524
 525 /* Comparison of two big arrays */
 526
 527 static int caml_ba_compare(value v1, value v2)
 528 {
 529   struct caml_ba_array * b1 = Caml_ba_array_val(v1);
 530   struct caml_ba_array * b2 = Caml_ba_array_val(v2);
 531   uintnat n, num_elts;
 532   int i;
 533
 534   /* Compare number of dimensions */
 535   if (b1->num_dims != b2->num_dims) return b2->num_dims - b1->num_dims;
 536   /* Same number of dimensions: compare dimensions lexicographically */
 537   for (i = 0; i < b1->num_dims; i++) {
 538     intnat d1 = b1->dim[i];
 539     intnat d2 = b2->dim[i];
 540     if (d1 != d2) return d1 < d2 ? -1 : 1;
 541   }
 542   /* Same dimensions: compare contents lexicographically */
 543   num_elts = caml_ba_num_elts(b1);
 544
 545 #define DO_INTEGER_COMPARISON(type) \
 546   { type * p1 = b1->data; type * p2 = b2->data; \
 547     for (n = 0; n < num_elts; n++) { \
 548       type e1 = *p1++; type e2 = *p2++; \
 549       if (e1 < e2) return -1; \
 550       if (e1 > e2) return 1; \
 551     } \
 552     return 0; \
 553   }
 554 #define DO_FLOAT_COMPARISON(type) \
 555   { type * p1 = b1->data; type * p2 = b2->data; \
 556     for (n = 0; n < num_elts; n++) { \
 557       type e1 = *p1++; type e2 = *p2++; \
 558       if (e1 < e2) return -1; \
 559       if (e1 > e2) return 1; \
 560       if (e1 != e2) { \
 561         caml_compare_unordered = 1; \
 562         if (e1 == e1) return 1; \
 563         if (e2 == e2) return -1; \
 564       } \
 565     } \
 566     return 0; \
 567   }
 568
 569   switch (b1->flags & CAML_BA_KIND_MASK) {
 570   case CAML_BA_COMPLEX32:
 571     num_elts *= 2; /*fallthrough*/
 572   case CAML_BA_FLOAT32:
 573     DO_FLOAT_COMPARISON(float);
 574   case CAML_BA_COMPLEX64:
 575     num_elts *= 2; /*fallthrough*/
 576   case CAML_BA_FLOAT64:
 577     DO_FLOAT_COMPARISON(double);
 578   case CAML_BA_SINT8:
 579     DO_INTEGER_COMPARISON(int8);
 580   case CAML_BA_UINT8:
 581     DO_INTEGER_COMPARISON(uint8);
 582   case CAML_BA_SINT16:
 583     DO_INTEGER_COMPARISON(int16);
 584   case CAML_BA_UINT16:
 585     DO_INTEGER_COMPARISON(uint16);
 586   case CAML_BA_INT32:
 587     DO_INTEGER_COMPARISON(int32);
 588   case CAML_BA_INT64:
 589 #ifdef ARCH_INT64_TYPE
 590     DO_INTEGER_COMPARISON(int64);
 591 #else
 592     { int64 * p1 = b1->data; int64 * p2 = b2->data;
 593       for (n = 0; n < num_elts; n++) {
 594         int64 e1 = *p1++; int64 e2 = *p2++;
 595         if ((int32)e1.h > (int32)e2.h) return 1;
 596         if ((int32)e1.h < (int32)e2.h) return -1;
 597         if (e1.l > e2.l) return 1;
 598         if (e1.l < e2.l) return -1;
 599       }
 600       return 0;
 601     }
 602 #endif
 603   case CAML_BA_CAML_INT:
 604   case CAML_BA_NATIVE_INT:
 605     DO_INTEGER_COMPARISON(intnat);
 606   default:
 607     Assert(0);
 608     return 0;                   /* should not happen */
 609   }
 610 #undef DO_INTEGER_COMPARISON
 611 #undef DO_FLOAT_COMPARISON
 612 }
 613
 614 /* Hashing of a bigarray */
 615
 616 static intnat caml_ba_hash(value v)
 617 {
 618   struct caml_ba_array * b = Caml_ba_array_val(v);
 619   intnat num_elts, n, h;
 620   int i;
 621
 622   num_elts = 1;
 623   for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
 624   if (num_elts >= 50) num_elts = 50;
 625   h = 0;
 626
 627 #define COMBINE(h,v) ((h << 4) + h + (v))
 628
 629   switch (b->flags & CAML_BA_KIND_MASK) {
 630   case CAML_BA_SINT8:
 631   case CAML_BA_UINT8: {
 632     uint8 * p = b->data;
 633     for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
 634     break;
 635   }
 636   case CAML_BA_SINT16:
 637   case CAML_BA_UINT16: {
 638     uint16 * p = b->data;
 639     for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
 640     break;
 641   }
 642   case CAML_BA_FLOAT32:
 643   case CAML_BA_COMPLEX32:
 644   case CAML_BA_INT32:
 645 #ifndef ARCH_SIXTYFOUR
 646   case CAML_BA_CAML_INT:
 647   case CAML_BA_NATIVE_INT:
 648 #endif
 649   {
 650     uint32 * p = b->data;
 651     for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
 652     break;
 653   }
 654   case CAML_BA_FLOAT64:
 655   case CAML_BA_COMPLEX64:
 656   case CAML_BA_INT64:
 657 #ifdef ARCH_SIXTYFOUR
 658   case CAML_BA_CAML_INT:
 659   case CAML_BA_NATIVE_INT:
 660 #endif
 661 #ifdef ARCH_SIXTYFOUR
 662   {
 663     uintnat * p = b->data;
 664     for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
 665     break;
 666   }
 667 #else
 668   {
 669     uint32 * p = b->data;
 670     for (n = 0; n < num_elts; n++) {
 671 #ifdef ARCH_BIG_ENDIAN
 672       h = COMBINE(h, p[1]); h = COMBINE(h, p[0]); p += 2;
 673 #else
 674       h = COMBINE(h, p[0]); h = COMBINE(h, p[1]); p += 2;
 675 #endif
 676     }
 677     break;
 678   }
 679 #endif
 680   }
 681 #undef COMBINE
 682   return h;
 683 }
 684
 685 static void caml_ba_serialize_longarray(void * data,
 686                                         intnat num_elts,
 687                                         intnat min_val, intnat max_val)
 688 {
 689 #ifdef ARCH_SIXTYFOUR
 690   int overflow_32 = 0;
 691   intnat * p, n;
 692   for (n = 0, p = data; n < num_elts; n++, p++) {
 693     if (*p < min_val || *p > max_val) { overflow_32 = 1; break; }
 694   }
 695   if (overflow_32) {
 696     caml_serialize_int_1(1);
 697     caml_serialize_block_8(data, num_elts);
 698   } else {
 699     caml_serialize_int_1(0);
 700     for (n = 0, p = data; n < num_elts; n++, p++)
 701       caml_serialize_int_4((int32) *p);
 702   }
 703 #else
 704   caml_serialize_int_1(0);
 705   caml_serialize_block_4(data, num_elts);
 706 #endif
 707 }
 708
 709 static void caml_ba_serialize(value v,
 710                               uintnat * wsize_32,
 711                               uintnat * wsize_64)
 712 {
 713   struct caml_ba_array * b = Caml_ba_array_val(v);
 714   intnat num_elts;
 715   int i;
 716
 717   /* Serialize header information */
 718   caml_serialize_int_4(b->num_dims);
 719   caml_serialize_int_4(b->flags & (CAML_BA_KIND_MASK | CAML_BA_LAYOUT_MASK));
 720   /* On a 64-bit machine, if any of the dimensions is >= 2^32,
 721      the size of the marshaled data will be >= 2^32 and
 722      extern_value() will fail.  So, it is safe to write the dimensions
 723      as 32-bit unsigned integers. */
 724   for (i = 0; i < b->num_dims; i++) caml_serialize_int_4(b->dim[i]);
 725   /* Compute total number of elements */
 726   num_elts = 1;
 727   for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
 728   /* Serialize elements */
 729   switch (b->flags & CAML_BA_KIND_MASK) {
 730   case CAML_BA_SINT8:
 731   case CAML_BA_UINT8:
 732     caml_serialize_block_1(b->data, num_elts); break;
 733   case CAML_BA_SINT16:
 734   case CAML_BA_UINT16:
 735     caml_serialize_block_2(b->data, num_elts); break;
 736   case CAML_BA_FLOAT32:
 737   case CAML_BA_INT32:
 738     caml_serialize_block_4(b->data, num_elts); break;
 739   case CAML_BA_COMPLEX32:
 740     caml_serialize_block_4(b->data, num_elts * 2); break;
 741   case CAML_BA_FLOAT64:
 742   case CAML_BA_INT64:
 743     caml_serialize_block_8(b->data, num_elts); break;
 744   case CAML_BA_COMPLEX64:
 745     caml_serialize_block_8(b->data, num_elts * 2); break;
 746   case CAML_BA_CAML_INT:
 747     caml_ba_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF);
 748     break;
 749   case CAML_BA_NATIVE_INT:
 750     caml_ba_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
 751     break;
 752   }
 753   /* Compute required size in Caml heap.  Assumes struct caml_ba_array
 754      is exactly 4 + num_dims words */
 755   Assert(sizeof(struct caml_ba_array) == 5 * sizeof(value));
 756   *wsize_32 = (4 + b->num_dims) * 4;
 757   *wsize_64 = (4 + b->num_dims) * 8;
 758 }
 759
 760 static void caml_ba_deserialize_longarray(void * dest, intnat num_elts)
 761 {
 762   int sixty = caml_deserialize_uint_1();
 763 #ifdef ARCH_SIXTYFOUR
 764   if (sixty) {
 765     caml_deserialize_block_8(dest, num_elts);
 766   } else {
 767     intnat * p, n;
 768     for (n = 0, p = dest; n < num_elts; n++, p++)
 769       *p = caml_deserialize_sint_4();
 770   }
 771 #else
 772   if (sixty)
 773     caml_deserialize_error("input_value: cannot read bigarray "
 774                       "with 64-bit Caml ints");
 775   caml_deserialize_block_4(dest, num_elts);
 776 #endif
 777 }
 778
 779 uintnat caml_ba_deserialize(void * dst)
 780 {
 781   struct caml_ba_array * b = dst;
 782   int i, elt_size;
 783   uintnat num_elts;
 784
 785   /* Read back header information */
 786   b->num_dims = caml_deserialize_uint_4();
 787   b->flags = caml_deserialize_uint_4() | CAML_BA_MANAGED;
 788   b->proxy = NULL;
 789   for (i = 0; i < b->num_dims; i++) b->dim[i] = caml_deserialize_uint_4();
 790   /* Compute total number of elements */
 791   num_elts = caml_ba_num_elts(b);
 792   /* Determine element size in bytes */
 793   if ((b->flags & CAML_BA_KIND_MASK) > CAML_BA_COMPLEX64)
 794     caml_deserialize_error("input_value: bad bigarray kind");
 795   elt_size = caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
 796   /* Allocate room for data */
 797   b->data = malloc(elt_size * num_elts);
 798   if (b->data == NULL)
 799     caml_deserialize_error("input_value: out of memory for bigarray");
 800   /* Read data */
 801   switch (b->flags & CAML_BA_KIND_MASK) {
 802   case CAML_BA_SINT8:
 803   case CAML_BA_UINT8:
 804     caml_deserialize_block_1(b->data, num_elts); break;
 805   case CAML_BA_SINT16:
 806   case CAML_BA_UINT16:
 807     caml_deserialize_block_2(b->data, num_elts); break;
 808   case CAML_BA_FLOAT32:
 809   case CAML_BA_INT32:
 810     caml_deserialize_block_4(b->data, num_elts); break;
 811   case CAML_BA_COMPLEX32:
 812     caml_deserialize_block_4(b->data, num_elts * 2); break;
 813   case CAML_BA_FLOAT64:
 814   case CAML_BA_INT64:
 815     caml_deserialize_block_8(b->data, num_elts); break;
 816   case CAML_BA_COMPLEX64:
 817     caml_deserialize_block_8(b->data, num_elts * 2); break;
 818   case CAML_BA_CAML_INT:
 819   case CAML_BA_NATIVE_INT:
 820     caml_ba_deserialize_longarray(b->data, num_elts); break;
 821   }
 822   return sizeof(struct caml_ba_array) + (b->num_dims - 1) * sizeof(intnat);
 823 }
 824
 825 /* Create / update proxy to indicate that b2 is a sub-array of b1 */
 826
 827 static void caml_ba_update_proxy(struct caml_ba_array * b1,
 828                                  struct caml_ba_array * b2)
 829 {
 830   struct caml_ba_proxy * proxy;
 831   /* Nothing to do for un-managed arrays */
 832   if ((b1->flags & CAML_BA_MANAGED_MASK) == CAML_BA_EXTERNAL) return;
 833   if (b1->proxy != NULL) {
 834     /* If b1 is already a proxy for a larger array, increment refcount of
 835        proxy */
 836     b2->proxy = b1->proxy;
 837     ++ b1->proxy->refcount;
 838   } else {
 839     /* Otherwise, create proxy and attach it to both b1 and b2 */
 840     proxy = caml_stat_alloc(sizeof(struct caml_ba_proxy));
 841     proxy->refcount = 2;      /* original array + sub array */
 842     proxy->data = b1->data;
 843     proxy->size =
 844       b1->flags & CAML_BA_MAPPED_FILE ? caml_ba_byte_size(b1) : 0;
 845     b1->proxy = proxy;
 846     b2->proxy = proxy;
 847   }
 848 }
 849
 850 /* Slicing */
 851
 852 CAMLprim value caml_ba_slice(value vb, value vind)
 853 {
 854   CAMLparam2 (vb, vind);
 855   #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
 856   CAMLlocal1 (res);
 857   intnat index[CAML_BA_MAX_NUM_DIMS];
 858   int num_inds, i;
 859   intnat offset;
 860   intnat * sub_dims;
 861   char * sub_data;
 862
 863   /* Check number of indices < number of dimensions of array */
 864   num_inds = Wosize_val(vind);
 865   if (num_inds >= b->num_dims)
 866     caml_invalid_argument("Bigarray.slice: too many indices");
 867   /* Compute offset and check bounds */
 868   if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
 869     /* We slice from the left */
 870     for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i));
 871     for (/*nothing*/; i < b->num_dims; i++) index[i] = 0;
 872     offset = caml_ba_offset(b, index);
 873     sub_dims = b->dim + num_inds;
 874   } else {
 875     /* We slice from the right */
 876     for (i = 0; i < num_inds; i++)
 877       index[b->num_dims - num_inds + i] = Long_val(Field(vind, i));
 878     for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1;
 879     offset = caml_ba_offset(b, index);
 880     sub_dims = b->dim;
 881   }
 882   sub_data =
 883     (char *) b->data +
 884     offset * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
 885   /* Allocate a Caml bigarray to hold the result */
 886   res = caml_ba_alloc(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
 887   /* Create or update proxy in case of managed bigarray */
 888   caml_ba_update_proxy(b, Caml_ba_array_val(res));
 889   /* Return result */
 890   CAMLreturn (res);
 891
 892   #undef b
 893 }
 894
 895 /* Extracting a sub-array of same number of dimensions */
 896
 897 CAMLprim value caml_ba_sub(value vb, value vofs, value vlen)
 898 {
 899   CAMLparam3 (vb, vofs, vlen);
 900   CAMLlocal1 (res);
 901   #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
 902   intnat ofs = Long_val(vofs);
 903   intnat len = Long_val(vlen);
 904   int i, changed_dim;
 905   intnat mul;
 906   char * sub_data;
 907
 908   /* Compute offset and check bounds */
 909   if ((b->flags & CAML_BA_LAYOUT_MASK) == CAML_BA_C_LAYOUT) {
 910     /* We reduce the first dimension */
 911     mul = 1;
 912     for (i = 1; i < b->num_dims; i++) mul *= b->dim[i];
 913     changed_dim = 0;
 914   } else {
 915     /* We reduce the last dimension */
 916     mul = 1;
 917     for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i];
 918     changed_dim = b->num_dims - 1;
 919     ofs--;                      /* Fortran arrays start at 1 */
 920   }
 921   if (ofs < 0 || len < 0 || ofs + len > b->dim[changed_dim])
 922     caml_invalid_argument("Bigarray.sub: bad sub-array");
 923   sub_data =
 924     (char *) b->data +
 925     ofs * mul * caml_ba_element_size[b->flags & CAML_BA_KIND_MASK];
 926   /* Allocate a Caml bigarray to hold the result */
 927   res = caml_ba_alloc(b->flags, b->num_dims, sub_data, b->dim);
 928   /* Doctor the changed dimension */
 929   Caml_ba_array_val(res)->dim[changed_dim] = len;
 930   /* Create or update proxy in case of managed bigarray */
 931   caml_ba_update_proxy(b, Caml_ba_array_val(res));
 932   /* Return result */
 933   CAMLreturn (res);
 934
 935   #undef b
 936 }
 937
 938 /* Copying a big array into another one */
 939
 940 CAMLprim value caml_ba_blit(value vsrc, value vdst)
 941 {
 942   struct caml_ba_array * src = Caml_ba_array_val(vsrc);
 943   struct caml_ba_array * dst = Caml_ba_array_val(vdst);
 944   int i;
 945   intnat num_bytes;
 946
 947   /* Check same numbers of dimensions and same dimensions */
 948   if (src->num_dims != dst->num_dims) goto blit_error;
 949   for (i = 0; i < src->num_dims; i++)
 950     if (src->dim[i] != dst->dim[i]) goto blit_error;
 951   /* Compute number of bytes in array data */
 952   num_bytes =
 953     caml_ba_num_elts(src)
 954     * caml_ba_element_size[src->flags & CAML_BA_KIND_MASK];
 955   /* Do the copying */
 956   memmove (dst->data, src->data, num_bytes);
 957   return Val_unit;
 958  blit_error:
 959   caml_invalid_argument("Bigarray.blit: dimension mismatch");
 960   return Val_unit;              /* not reached */
 961 }
 962
 963 /* Filling a big array with a given value */
 964
 965 CAMLprim value caml_ba_fill(value vb, value vinit)
 966 {
 967   struct caml_ba_array * b = Caml_ba_array_val(vb);
 968   intnat num_elts = caml_ba_num_elts(b);
 969
 970   switch (b->flags & CAML_BA_KIND_MASK) {
 971   default:
 972     Assert(0);
 973   case CAML_BA_FLOAT32: {
 974     float init = Double_val(vinit);
 975     float * p;
 976     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
 977     break;
 978   }
 979   case CAML_BA_FLOAT64: {
 980     double init = Double_val(vinit);
 981     double * p;
 982     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
 983     break;
 984   }
 985   case CAML_BA_SINT8:
 986   case CAML_BA_UINT8: {
 987     int init = Int_val(vinit);
 988     char * p;
 989     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
 990     break;
 991   }
 992   case CAML_BA_SINT16:
 993   case CAML_BA_UINT16: {
 994     int init = Int_val(vinit);
 995     int16 * p;
 996     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
 997     break;
 998   }
 999   case CAML_BA_INT32: {
1000     int32 init = Int32_val(vinit);
1001     int32 * p;
1002     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
1003     break;
1004   }
1005   case CAML_BA_INT64: {
1006     int64 init = Int64_val(vinit);
1007     int64 * p;
1008     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
1009     break;
1010   }
1011   case CAML_BA_NATIVE_INT: {
1012     intnat init = Nativeint_val(vinit);
1013     intnat * p;
1014     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
1015     break;
1016   }
1017   case CAML_BA_CAML_INT: {
1018     intnat init = Long_val(vinit);
1019     intnat * p;
1020     for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
1021     break;
1022   }
1023   case CAML_BA_COMPLEX32: {
1024     float init0 = Double_field(vinit, 0);
1025     float init1 = Double_field(vinit, 1);
1026     float * p;
1027     for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }
1028     break;
1029   }
1030   case CAML_BA_COMPLEX64: {
1031     double init0 = Double_field(vinit, 0);
1032     double init1 = Double_field(vinit, 1);
1033     double * p;
1034     for (p = b->data; num_elts > 0; num_elts--) { *p++ = init0; *p++ = init1; }
1035     break;
1036   }
1037   }
1038   return Val_unit;
1039 }
1040
1041 /* Reshape an array: change dimensions and number of dimensions, preserving
1042    array contents */
1043
1044 CAMLprim value caml_ba_reshape(value vb, value vdim)
1045 {
1046   CAMLparam2 (vb, vdim);
1047   CAMLlocal1 (res);
1048 #define b ((struct caml_ba_array *) Caml_ba_array_val(vb))
1049   intnat dim[CAML_BA_MAX_NUM_DIMS];
1050   mlsize_t num_dims;
1051   uintnat num_elts;
1052   int i;
1053
1054   num_dims = Wosize_val(vdim);
1055   if (num_dims < 1 || num_dims > CAML_BA_MAX_NUM_DIMS)
1056     caml_invalid_argument("Bigarray.reshape: bad number of dimensions");
1057   num_elts = 1;
1058   for (i = 0; i < num_dims; i++) {
1059     dim[i] = Long_val(Field(vdim, i));
1060     if (dim[i] < 0 || dim[i] > 0x7FFFFFFFL)
1061       caml_invalid_argument("Bigarray.reshape: negative dimension");
1062     num_elts *= dim[i];
1063   }
1064   /* Check that sizes agree */
1065   if (num_elts != caml_ba_num_elts(b))
1066     caml_invalid_argument("Bigarray.reshape: size mismatch");
1067   /* Create bigarray with same data and new dimensions */
1068   res = caml_ba_alloc(b->flags, num_dims, b->data, dim);
1069   /* Create or update proxy in case of managed bigarray */
1070   caml_ba_update_proxy(b, Caml_ba_array_val(res));
1071   /* Return result */
1072   CAMLreturn (res);
1073
1074 #undef b
1075 }
1076
1077 /* Initialization */
1078
1079 CAMLprim value caml_ba_init(value unit)
1080 {
1081   caml_register_custom_operations(&caml_ba_ops);
1082   return Val_unit;
1083 }