Premier jet des bigarrays
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@2849 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
Xavier Leroy
parent
eb07ca4f01
commit
bd1a7c9b32
|
|
@ -0,0 +1,10 @@
|
|||
bigarray_stubs.o: bigarray_stubs.c ../../byterun/alloc.h \
|
||||
../../byterun/misc.h ../../byterun/config.h \
|
||||
../../byterun/../config/m.h ../../byterun/../config/s.h \
|
||||
../../byterun/mlvalues.h bigarray.h ../../byterun/custom.h \
|
||||
../../byterun/fail.h ../../byterun/intext.h ../../byterun/io.h \
|
||||
../../byterun/fix_code.h ../../byterun/memory.h ../../byterun/gc.h \
|
||||
../../byterun/major_gc.h ../../byterun/freelist.h \
|
||||
../../byterun/minor_gc.h
|
||||
bigarray.cmo: bigarray.cmi
|
||||
bigarray.cmx: bigarray.cmi
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
#########################################################################
|
||||
# #
|
||||
# Objective Caml #
|
||||
# #
|
||||
# Xavier Leroy, projet Cristal, INRIA Rocquencourt #
|
||||
# #
|
||||
# Copyright 1999 Institut National de Recherche en Informatique et #
|
||||
# en Automatique. All rights reserved. This file is distributed #
|
||||
# under the terms of the GNU Library General Public License. #
|
||||
# #
|
||||
#########################################################################
|
||||
|
||||
# $Id$
|
||||
|
||||
include ../../config/Makefile
|
||||
|
||||
CC=$(BYTECC)
|
||||
CFLAGS=-I../../byterun -g -O $(BYTECCCOMPOPTS)
|
||||
CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib -I ../unix
|
||||
CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib -I ../unix
|
||||
|
||||
C_OBJS=bigarray_stubs.o
|
||||
|
||||
CAML_OBJS=bigarray.cmo
|
||||
|
||||
all: libbigarray.a bigarray.cma
|
||||
|
||||
allopt: libbigarray.a bigarray.cmxa
|
||||
|
||||
libbigarray.a: $(C_OBJS)
|
||||
rm -f libbigarray.a
|
||||
ar rc libbigarray.a $(C_OBJS)
|
||||
$(RANLIB) libbigarray.a
|
||||
|
||||
bigarray.cma: $(CAML_OBJS)
|
||||
$(CAMLC) -a -o bigarray.cma $(CAML_OBJS)
|
||||
|
||||
bigarray.cmxa: $(CAML_OBJS:.cmo=.cmx)
|
||||
$(CAMLOPT) -a -o bigarray.cmxa $(CAML_OBJS:.cmo=.cmx)
|
||||
|
||||
partialclean:
|
||||
rm -f *.cm*
|
||||
|
||||
clean: partialclean
|
||||
rm -f libbigarray.a *.o
|
||||
|
||||
.SUFFIXES: .ml .mli .cmo .cmi .cmx
|
||||
|
||||
.mli.cmi:
|
||||
$(CAMLC) -c $(COMPFLAGS) $<
|
||||
|
||||
.ml.cmo:
|
||||
$(CAMLC) -c $(COMPFLAGS) $<
|
||||
|
||||
.ml.cmx:
|
||||
$(CAMLOPT) -c $(COMPFLAGS) $<
|
||||
|
||||
depend:
|
||||
gcc -MM $(CFLAGS) *.c > .depend
|
||||
../../boot/ocamlrun ../../tools/ocamldep *.mli *.ml >> .depend
|
||||
|
||||
include .depend
|
||||
|
|
@ -0,0 +1,137 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Manuel Serrano et Xavier Leroy, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2000 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. All rights reserved. This file is distributed *)
|
||||
(* under the terms of the GNU Library General Public License. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
|
||||
|
||||
type ('a, 'b) kind = int
|
||||
|
||||
type int8_signed_elt
|
||||
type int8_unsigned_elt
|
||||
type int16_signed_elt
|
||||
type int16_unsigned_elt
|
||||
type int_elt
|
||||
type int32_elt
|
||||
type int64_elt
|
||||
type nativeint_elt
|
||||
type float4_elt
|
||||
type float8_elt
|
||||
|
||||
(* Keep those constants in sync with the caml_bigarray_kind enumeration
|
||||
in bigarray.h *)
|
||||
|
||||
let float4 = 0
|
||||
let float8 = 1
|
||||
let int8_signed = 2
|
||||
let int8_unsigned = 3
|
||||
let int16_signed = 4
|
||||
let int16_unsigned = 5
|
||||
let int32 = 6
|
||||
let int64 = 7
|
||||
let int = 8
|
||||
let nativeint = 9
|
||||
|
||||
type 'a layout = int
|
||||
|
||||
type c_layout
|
||||
type fortran_layout
|
||||
|
||||
(* Keep those constants in sync with the caml_bigarray_layout enumeration
|
||||
in bigarray.h *)
|
||||
|
||||
let c_layout = 0
|
||||
let fortran_layout = 0x100
|
||||
|
||||
module Genarray = struct
|
||||
type ('a, 'b, 'c) t
|
||||
external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t
|
||||
= "bigarray_create"
|
||||
external get: ('a, 'b, 'c) t -> int array -> 'a
|
||||
= "bigarray_get_generic"
|
||||
external set: ('a, 'b, 'c) t -> int array -> 'a -> unit
|
||||
= "bigarray_set_generic"
|
||||
external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims"
|
||||
external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_dim"
|
||||
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t
|
||||
= "bigarray_sub"
|
||||
external sub_right: ('a, 'b, fortran_layout) t -> int -> int ->
|
||||
('a, 'b, fortran_layout) t
|
||||
= "bigarray_sub"
|
||||
external slice_left: ('a, 'b, c_layout) t -> int array ->
|
||||
('a, 'b, c_layout) t
|
||||
= "bigarray_slice"
|
||||
external slice_right: ('a, 'b, fortran_layout) t -> int array ->
|
||||
('a, 'b, fortran_layout) t
|
||||
= "bigarray_slice"
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit
|
||||
= "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
module Array1 = struct
|
||||
type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
|
||||
let create kind layout dim =
|
||||
Genarray.create kind layout [|dim|]
|
||||
external get: ('a, 'b, 'c) t -> int -> 'a = "bigarray_get_1"
|
||||
external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "bigarray_set_1"
|
||||
let dim a = Genarray.nth_dim a 0
|
||||
external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "bigarray_sub"
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
module Array2 = struct
|
||||
type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
|
||||
let create kind layout dim1 dim2 =
|
||||
Genarray.create kind layout [|dim1; dim2|]
|
||||
external get: ('a, 'b, 'c) t -> int -> int -> 'a = "bigarray_get_2"
|
||||
external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "bigarray_set_2"
|
||||
let dim1 a = Genarray.nth_dim a 0
|
||||
let dim2 a = Genarray.nth_dim a 1
|
||||
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
|
||||
external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub"
|
||||
let slice_left a n = Genarray.slice_left a [|n|]
|
||||
let slice_right a n = Genarray.slice_right a [|n|]
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
module Array3 = struct
|
||||
type ('a, 'b, 'c) t = ('a, 'b, 'c) Genarray.t
|
||||
let create kind layout dim1 dim2 dim3 =
|
||||
Genarray.create kind layout [|dim1; dim2; dim3|]
|
||||
external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "bigarray_get_3"
|
||||
external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "bigarray_set_3"
|
||||
let dim1 a = Genarray.nth_dim a 0
|
||||
let dim2 a = Genarray.nth_dim a 1
|
||||
let dim3 a = Genarray.nth_dim a 2
|
||||
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
|
||||
external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub"
|
||||
let slice_left_1 a n m = Genarray.slice_left a [|n; m|]
|
||||
let slice_right_1 a n m = Genarray.slice_right a [|n; m|]
|
||||
let slice_left_2 a n = Genarray.slice_left a [|n|]
|
||||
let slice_right_2 a n = Genarray.slice_right a [|n|]
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
|
||||
external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity"
|
||||
external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity"
|
||||
let array1_of_genarray a =
|
||||
if Genarray.num_dims a = 1 then a else invalid_arg "Bigarray.array1_of_genarray"
|
||||
let array2_of_genarray a =
|
||||
if Genarray.num_dims a = 2 then a else invalid_arg "Bigarray.array2_of_genarray"
|
||||
let array3_of_genarray a =
|
||||
if Genarray.num_dims a = 3 then a else invalid_arg "Bigarray.array3_of_genarray"
|
||||
|
||||
|
|
@ -0,0 +1,115 @@
|
|||
(***********************************************************************)
|
||||
(* *)
|
||||
(* Objective Caml *)
|
||||
(* *)
|
||||
(* Manuel Serrano et Xavier Leroy, INRIA Rocquencourt *)
|
||||
(* *)
|
||||
(* Copyright 2000 Institut National de Recherche en Informatique et *)
|
||||
(* en Automatique. All rights reserved. This file is distributed *)
|
||||
(* under the terms of the GNU Library General Public License. *)
|
||||
(* *)
|
||||
(***********************************************************************)
|
||||
|
||||
(* $Id$ *)
|
||||
|
||||
(* Module [Bigarray]: large, multi-dimensional, numerical arrays *)
|
||||
|
||||
(* Bla bla *)
|
||||
|
||||
type ('a, 'b) kind
|
||||
|
||||
type int8_signed_elt
|
||||
type int8_unsigned_elt
|
||||
type int16_signed_elt
|
||||
type int16_unsigned_elt
|
||||
type int_elt
|
||||
type int32_elt
|
||||
type int64_elt
|
||||
type nativeint_elt
|
||||
type float4_elt
|
||||
type float8_elt
|
||||
|
||||
val int8_signed: (int, int8_signed_elt) kind
|
||||
val int8_unsigned: (int, int8_unsigned_elt) kind
|
||||
val int16_signed: (int, int16_signed_elt) kind
|
||||
val int16_unsigned: (int, int16_unsigned_elt) kind
|
||||
val int: (int, int_elt) kind
|
||||
val int32: (int32, int32_elt) kind
|
||||
val int64: (int64, int64_elt) kind
|
||||
val nativeint: (nativeint, nativeint_elt) kind
|
||||
val float4: (float, float4_elt) kind
|
||||
val float8: (float, float8_elt) kind
|
||||
|
||||
type 'a layout
|
||||
|
||||
type c_layout
|
||||
type fortran_layout
|
||||
|
||||
val c_layout: c_layout layout
|
||||
val fortran_layout: fortran_layout layout
|
||||
|
||||
module Array1: sig
|
||||
type ('a, 'b, 'c) t
|
||||
val create: ('a, 'b) kind -> 'c layout -> int -> ('a, 'b, 'c) t
|
||||
external get: ('a, 'b, 'c) t -> int -> 'a = "bigarray_get_1"
|
||||
external set: ('a, 'b, 'c) t -> int -> 'a -> unit = "bigarray_set_1"
|
||||
val dim: ('a, 'b, 'c) t -> int
|
||||
external sub: ('a, 'b, 'c) t -> int -> int -> ('a, 'b, 'c) t = "bigarray_sub"
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
module Array2: sig
|
||||
type ('a, 'b, 'c) t
|
||||
val create: ('a, 'b) kind -> 'c layout -> int -> int -> ('a, 'b, 'c) t
|
||||
external get: ('a, 'b, 'c) t -> int -> int -> 'a = "bigarray_get_2"
|
||||
external set: ('a, 'b, 'c) t -> int -> int -> 'a -> unit = "bigarray_set_2"
|
||||
val dim1: ('a, 'b, 'c) t -> int
|
||||
val dim2: ('a, 'b, 'c) t -> int
|
||||
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
|
||||
external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub"
|
||||
val slice_left: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array1.t
|
||||
val slice_right: ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array1.t
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
module Array3: sig
|
||||
type ('a, 'b, 'c) t
|
||||
val create: ('a, 'b) kind -> 'c layout -> int -> int -> int -> ('a, 'b, 'c) t
|
||||
external get: ('a, 'b, 'c) t -> int -> int -> int -> 'a = "bigarray_get_3"
|
||||
external set: ('a, 'b, 'c) t -> int -> int -> int -> 'a -> unit = "bigarray_set_3"
|
||||
val dim1: ('a, 'b, 'c) t -> int
|
||||
val dim2: ('a, 'b, 'c) t -> int
|
||||
val dim3: ('a, 'b, 'c) t -> int
|
||||
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
|
||||
external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub"
|
||||
val slice_left_1: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) Array1.t
|
||||
val slice_right_1: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) Array1.t
|
||||
val slice_left_2: ('a, 'b, c_layout) t -> int -> ('a, 'b, c_layout) Array2.t
|
||||
val slice_right_2: ('a, 'b, fortran_layout) t -> int -> ('a, 'b, fortran_layout) Array2.t
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
module Genarray: sig
|
||||
type ('a, 'b, 'c) t
|
||||
external create: ('a, 'b) kind -> 'c layout -> int array -> ('a, 'b, 'c) t = "bigarray_create"
|
||||
external get: ('a, 'b, 'c) t -> int array -> 'a = "bigarray_get_generic"
|
||||
external set: ('a, 'b, 'c) t -> int array -> 'a -> unit = "bigarray_set_generic"
|
||||
external num_dims: ('a, 'b, 'c) t -> int = "bigarray_num_dims"
|
||||
external nth_dim: ('a, 'b, 'c) t -> int -> int = "bigarray_dim"
|
||||
external sub_left: ('a, 'b, c_layout) t -> int -> int -> ('a, 'b, c_layout) t = "bigarray_sub"
|
||||
external sub_right: ('a, 'b, fortran_layout) t -> int -> int -> ('a, 'b, fortran_layout) t = "bigarray_sub"
|
||||
external slice_left: ('a, 'b, c_layout) t -> int array -> ('a, 'b, c_layout) t = "bigarray_slice"
|
||||
external slice_right: ('a, 'b, fortran_layout) t -> int array -> ('a, 'b, fortran_layout) t = "bigarray_slice"
|
||||
external blit: ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> unit = "bigarray_blit"
|
||||
external fill: ('a, 'b, 'c) t -> 'a -> unit = "bigarray_fill"
|
||||
end
|
||||
|
||||
external genarray_of_array1: ('a, 'b, 'c) Array1.t -> ('a, 'b, 'c) Genarray.t = "%identity"
|
||||
external genarray_of_array2: ('a, 'b, 'c) Array2.t -> ('a, 'b, 'c) Genarray.t = "%identity"
|
||||
external genarray_of_array3: ('a, 'b, 'c) Array3.t -> ('a, 'b, 'c) Genarray.t = "%identity"
|
||||
val array1_of_genarray: ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array1.t
|
||||
val array2_of_genarray: ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array2.t
|
||||
val array3_of_genarray: ('a, 'b, 'c) Genarray.t -> ('a, 'b, 'c) Array3.t
|
||||
|
|
@ -0,0 +1,837 @@
|
|||
/***********************************************************************/
|
||||
/* */
|
||||
/* Objective Caml */
|
||||
/* */
|
||||
/* Manuel Serrano and Xavier Leroy, INRIA Rocquencourt */
|
||||
/* */
|
||||
/* Copyright 2000 Institut National de Recherche en Informatique et */
|
||||
/* en Automatique. All rights reserved. This file is distributed */
|
||||
/* under the terms of the GNU Library General Public License. */
|
||||
/* */
|
||||
/***********************************************************************/
|
||||
|
||||
/* $Id$ */
|
||||
|
||||
#include <stddef.h>
|
||||
#include <stdarg.h>
|
||||
#include "alloc.h"
|
||||
#include "bigarray.h"
|
||||
#include "custom.h"
|
||||
#include "fail.h"
|
||||
#include "intext.h"
|
||||
#include "memory.h"
|
||||
#include "mlvalues.h"
|
||||
|
||||
/* Compute the number of elements of a big array */
|
||||
|
||||
static long bigarray_num_elts(struct caml_bigarray * b)
|
||||
{
|
||||
long num_elts;
|
||||
int i;
|
||||
num_elts = 1;
|
||||
for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
|
||||
return num_elts;
|
||||
}
|
||||
|
||||
/* Size in bytes of a bigarray element, indexed by bigarray kind */
|
||||
|
||||
static int bigarray_element_size[] =
|
||||
{ 4 /*FLOAT4*/, 8 /*FLOAT8*/,
|
||||
1 /*SINT8*/, 1 /*UINT8*/,
|
||||
2 /*SINT16*/, 2 /*UINT16*/,
|
||||
4 /*INT32*/, 8 /*INT64*/,
|
||||
sizeof(value) /*CAML_INT*/, sizeof(value) /*NATIVE_INT*/
|
||||
};
|
||||
|
||||
/* Allocation of a big array */
|
||||
|
||||
static struct custom_operations bigarray_ops;
|
||||
|
||||
#define MAX_BIGARRAY_MEMORY 128*1024*1024
|
||||
/* 128 Mb -- after allocating that much, it's probably worth speeding
|
||||
up the major GC */
|
||||
|
||||
value alloc_bigarray(int flags, int num_dims, void * data, long * dim)
|
||||
{
|
||||
long num_elts, size;
|
||||
int i;
|
||||
value res;
|
||||
struct caml_bigarray * b;
|
||||
|
||||
Assert(num_dims >= 1 && num_dims <= MAX_NUM_DIMS);
|
||||
Assert((flags & BIGARRAY_KIND_MASK) <= BIGARRAY_NATIVE_INT);
|
||||
size = 0;
|
||||
if (data == NULL) {
|
||||
num_elts = 1;
|
||||
for (i = 0; i < num_dims; i++) num_elts = num_elts * dim[i];
|
||||
size = num_elts * bigarray_element_size[flags & BIGARRAY_KIND_MASK];
|
||||
data = stat_alloc(size);
|
||||
flags |= BIGARRAY_MANAGED;
|
||||
}
|
||||
res = alloc_custom(&bigarray_ops,
|
||||
sizeof(struct caml_bigarray)
|
||||
+ (num_dims - 1) * sizeof(long),
|
||||
size, MAX_BIGARRAY_MEMORY);
|
||||
b = Bigarray_val(res);
|
||||
b->data = data;
|
||||
b->num_dims = num_dims;
|
||||
b->flags = flags;
|
||||
b->proxy = NULL;
|
||||
for (i = 0; i < num_dims; i++) b->dim[i] = dim[i];
|
||||
return res;
|
||||
}
|
||||
|
||||
/* Same as alloc_bigarray, but dimensions are passed as a list of
|
||||
arguments */
|
||||
|
||||
value alloc_bigarray_dims(int flags, int num_dims, void * data, ...)
|
||||
{
|
||||
va_list ap;
|
||||
long dim[MAX_NUM_DIMS];
|
||||
int i;
|
||||
value res;
|
||||
|
||||
va_start(ap, data);
|
||||
for (i = 0; i < num_dims; i++) dim[i] = va_arg(ap, long);
|
||||
va_end(ap);
|
||||
res = alloc_bigarray(flags, num_dims, data, dim);
|
||||
return res;
|
||||
}
|
||||
|
||||
/* Allocate a bigarray from Caml */
|
||||
|
||||
value bigarray_create(value vkind, value vlayout, value vdim)
|
||||
{
|
||||
long dim[MAX_NUM_DIMS];
|
||||
mlsize_t num_dims;
|
||||
int i, flags;
|
||||
|
||||
num_dims = Wosize_val(vdim);
|
||||
if (num_dims < 1 || num_dims > MAX_NUM_DIMS)
|
||||
invalid_argument("Bigarray.alloc: bad number of dimensions");
|
||||
for (i = 0; i < num_dims; i++) dim[i] = Long_val(Field(vdim, i));
|
||||
flags = Int_val(vkind) | Int_val(vlayout);
|
||||
return alloc_bigarray(flags, num_dims, NULL, dim);
|
||||
}
|
||||
|
||||
/* Given a big array and a vector of indices, check that the indices
|
||||
are within the bounds and return the offset of the corresponding
|
||||
array element in the data part of the array. */
|
||||
|
||||
static long bigarray_offset(struct caml_bigarray * b, long * index)
|
||||
{
|
||||
long offset;
|
||||
int i;
|
||||
|
||||
offset = 0;
|
||||
if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) {
|
||||
/* C-style layout: row major, indices start at 0 */
|
||||
for (i = 0; i < b->num_dims; i++) {
|
||||
if ((unsigned long) index[i] >= (unsigned long) b->dim[i])
|
||||
invalid_argument("Bigarray: out-of-bound access");
|
||||
offset = offset * b->dim[i] + index[i];
|
||||
}
|
||||
} else {
|
||||
/* Fortran-style layout: column major, indices start at 1 */
|
||||
for (i = b->num_dims - 1; i >= 0; i--) {
|
||||
if ((unsigned long) (index[i] - 1) >= (unsigned long) b->dim[i])
|
||||
invalid_argument("Bigarray: out-of-bound access");
|
||||
offset = offset * b->dim[i] + (index[i] - 1);
|
||||
}
|
||||
}
|
||||
return offset;
|
||||
}
|
||||
|
||||
/* Generic code to read from a big array */
|
||||
|
||||
value bigarray_get_N(value vb, value * vind, int nind)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
long index[MAX_NUM_DIMS];
|
||||
int i;
|
||||
long offset;
|
||||
|
||||
/* Check number of indices = number of dimensions of array
|
||||
(maybe not necessary if ML typing guarantees this) */
|
||||
if (nind != b->num_dims)
|
||||
invalid_argument("Bigarray.get: wrong number of indices");
|
||||
/* Compute offset and check bounds */
|
||||
for (i = 0; i < b->num_dims; i++) index[i] = Long_val(vind[i]);
|
||||
offset = bigarray_offset(b, index);
|
||||
/* Perform read */
|
||||
switch ((b->flags) & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_FLOAT4:
|
||||
return copy_double(((float *) b->data)[offset]);
|
||||
case BIGARRAY_FLOAT8:
|
||||
return copy_double(((double *) b->data)[offset]);
|
||||
case BIGARRAY_SINT8:
|
||||
return Val_int(((schar *) b->data)[offset]);
|
||||
case BIGARRAY_UINT8:
|
||||
return Val_int(((unsigned char *) b->data)[offset]);
|
||||
case BIGARRAY_SINT16:
|
||||
return Val_int(((int16 *) b->data)[offset]);
|
||||
case BIGARRAY_UINT16:
|
||||
return Val_int(((uint16 *) b->data)[offset]);
|
||||
case BIGARRAY_INT32:
|
||||
return copy_int32(((int32 *) b->data)[offset]);
|
||||
case BIGARRAY_INT64:
|
||||
return copy_int64(((int64 *) b->data)[offset]);
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
return copy_nativeint(((long *) b->data)[offset]);
|
||||
default:
|
||||
Assert(0);
|
||||
case BIGARRAY_CAML_INT:
|
||||
return Val_long(((long *) b->data)[offset]);
|
||||
}
|
||||
}
|
||||
|
||||
value bigarray_get_1(value vb, value vind1)
|
||||
{
|
||||
return bigarray_get_N(vb, &vind1, 1);
|
||||
}
|
||||
|
||||
value bigarray_get_2(value vb, value vind1, value vind2)
|
||||
{
|
||||
value vind[2];
|
||||
vind[0] = vind1; vind[1] = vind2;
|
||||
return bigarray_get_N(vb, vind, 2);
|
||||
}
|
||||
|
||||
value bigarray_get_3(value vb, value vind1, value vind2, value vind3)
|
||||
{
|
||||
value vind[3];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
|
||||
return bigarray_get_N(vb, vind, 3);
|
||||
}
|
||||
|
||||
#if 0
|
||||
value bigarray_get_4(value vb, value vind1, value vind2,
|
||||
value vind3, value vind4)
|
||||
{
|
||||
value vind[4];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
|
||||
return bigarray_get_N(vb, vind, 4);
|
||||
}
|
||||
|
||||
value bigarray_get_5(value vb, value vind1, value vind2,
|
||||
value vind3, value vind4, value vind5)
|
||||
{
|
||||
value vind[5];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
|
||||
vind[3] = vind4; vind[4] = vind5;
|
||||
return bigarray_get_N(vb, vind, 5);
|
||||
}
|
||||
|
||||
value bigarray_get_6(value vb, value vind1, value vind2,
|
||||
value vind3, value vind4, value vind5, value vind6)
|
||||
{
|
||||
value vind[6];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
|
||||
vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
|
||||
return bigarray_get_N(vb, vind, 6);
|
||||
}
|
||||
#endif
|
||||
|
||||
value bigarray_get_generic(value vb, value vind)
|
||||
{
|
||||
return bigarray_get_N(vb, &Field(vind, 0), Wosize_val(vind));
|
||||
}
|
||||
|
||||
/* Generic write to a big array */
|
||||
|
||||
static value bigarray_set_aux(value vb, value * vind, long nind, value newval)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
long index[MAX_NUM_DIMS];
|
||||
int i;
|
||||
long offset;
|
||||
|
||||
/* Check number of indices = number of dimensions of array
|
||||
(maybe not necessary if ML typing guarantees this) */
|
||||
if (nind != b->num_dims)
|
||||
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 = bigarray_offset(b, index);
|
||||
/* Perform write */
|
||||
switch (b->flags & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_FLOAT4:
|
||||
((float *) b->data)[offset] = Double_val(newval); break;
|
||||
case BIGARRAY_FLOAT8:
|
||||
((double *) b->data)[offset] = Double_val(newval); break;
|
||||
case BIGARRAY_SINT8:
|
||||
case BIGARRAY_UINT8:
|
||||
((schar *) b->data)[offset] = Int_val(newval); break;
|
||||
case BIGARRAY_SINT16:
|
||||
case BIGARRAY_UINT16:
|
||||
((int16 *) b->data)[offset] = Int_val(newval); break;
|
||||
case BIGARRAY_INT32:
|
||||
((int32 *) b->data)[offset] = Int32_val(newval); break;
|
||||
case BIGARRAY_INT64:
|
||||
((int64 *) b->data)[offset] = Int64_val(newval); break;
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
((long *) b->data)[offset] = Nativeint_val(newval); break;
|
||||
default:
|
||||
Assert(0);
|
||||
case BIGARRAY_CAML_INT:
|
||||
((long *) b->data)[offset] = Long_val(newval); break;
|
||||
}
|
||||
return Val_unit;
|
||||
}
|
||||
|
||||
value bigarray_set_1(value vb, value vind1, value newval)
|
||||
{
|
||||
return bigarray_set_aux(vb, &vind1, 1, newval);
|
||||
}
|
||||
|
||||
value bigarray_set_2(value vb, value vind1, value vind2, value newval)
|
||||
{
|
||||
value vind[2];
|
||||
vind[0] = vind1; vind[1] = vind2;
|
||||
return bigarray_set_aux(vb, vind, 2, newval);
|
||||
}
|
||||
|
||||
value bigarray_set_3(value vb, value vind1, value vind2, value vind3,
|
||||
value newval)
|
||||
{
|
||||
value vind[3];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
|
||||
return bigarray_set_aux(vb, vind, 3, newval);
|
||||
}
|
||||
|
||||
#if 0
|
||||
value bigarray_set_4(value vb, value vind1, value vind2,
|
||||
value vind3, value vind4, value newval)
|
||||
{
|
||||
value vind[4];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3; vind[3] = vind4;
|
||||
return bigarray_set_aux(vb, vind, 4, newval);
|
||||
}
|
||||
|
||||
value bigarray_set_5(value vb, value vind1, value vind2,
|
||||
value vind3, value vind4, value vind5, value newval)
|
||||
{
|
||||
value vind[5];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
|
||||
vind[3] = vind4; vind[4] = vind5;
|
||||
return bigarray_set_aux(vb, vind, 5, newval);
|
||||
}
|
||||
|
||||
value bigarray_set_6(value vb, value vind1, value vind2,
|
||||
value vind3, value vind4, value vind5,
|
||||
value vind6, value newval)
|
||||
{
|
||||
value vind[6];
|
||||
vind[0] = vind1; vind[1] = vind2; vind[2] = vind3;
|
||||
vind[3] = vind4; vind[4] = vind5; vind[5] = vind6;
|
||||
return bigarray_set_aux(vb, vind, 6, newval);
|
||||
}
|
||||
|
||||
value bigarray_set_N(value vb, value * vind, int nargs)
|
||||
{
|
||||
return bigarray_set_aux(vb, vind, nargs - 1, vind[nargs - 1]);
|
||||
}
|
||||
#endif
|
||||
|
||||
value bigarray_set_generic(value vb, value vind, value newval)
|
||||
{
|
||||
return bigarray_set_aux(vb, &Field(vind, 0), Wosize_val(vind), newval);
|
||||
}
|
||||
|
||||
/* Return the number of dimensions of a big array */
|
||||
|
||||
value bigarray_num_dims(value vb)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
return Val_long(b->num_dims);
|
||||
}
|
||||
|
||||
/* Return the n-th dimension of a big array */
|
||||
|
||||
value bigarray_dim(value vb, value vn)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
long n = Long_val(vn);
|
||||
if (n >= b->num_dims) invalid_argument("Bigarray.dim");
|
||||
return Val_long(b->dim[n]);
|
||||
}
|
||||
|
||||
/* Finalization of a big array */
|
||||
|
||||
static void bigarray_finalize(value v)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(v);
|
||||
if ((b->flags & BIGARRAY_MANAGED_MASK) == BIGARRAY_EXTERNAL) return;
|
||||
if (b->proxy == NULL) {
|
||||
free(b->data);
|
||||
} else {
|
||||
if (-- b->proxy->refcount == 0) {
|
||||
stat_free(b->proxy->data);
|
||||
stat_free(b->proxy);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
/* Comparison of two big arrays */
|
||||
|
||||
static int bigarray_compare(value v1, value v2)
|
||||
{
|
||||
struct caml_bigarray * b1 = Bigarray_val(v1);
|
||||
struct caml_bigarray * b2 = Bigarray_val(v2);
|
||||
long n, num_elts;
|
||||
int i;
|
||||
|
||||
/* Compare kind and layout */
|
||||
int flags1 = b1->flags & (BIGARRAY_KIND_MASK | BIGARRAY_LAYOUT_MASK);
|
||||
int flags2 = b2->flags & (BIGARRAY_KIND_MASK | BIGARRAY_LAYOUT_MASK);
|
||||
if (flags1 != flags2) return flags2 - flags1;
|
||||
/* Same kind and layout: 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++) {
|
||||
long d1 = b1->dim[i];
|
||||
long d2 = b2->dim[i];
|
||||
if (d1 != d2) return d1 < d2 ? -1 : 1;
|
||||
}
|
||||
/* Same dimensions: compare contents lexicographically */
|
||||
num_elts = bigarray_num_elts(b1);
|
||||
|
||||
#define DO_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 e1 < e2 ? -1 : 1; \
|
||||
} \
|
||||
return 0; \
|
||||
}
|
||||
|
||||
switch (b1->flags & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_FLOAT4:
|
||||
DO_COMPARISON(float);
|
||||
case BIGARRAY_FLOAT8:
|
||||
DO_COMPARISON(double);
|
||||
case BIGARRAY_SINT8:
|
||||
DO_COMPARISON(schar);
|
||||
case BIGARRAY_UINT8:
|
||||
DO_COMPARISON(unsigned char);
|
||||
case BIGARRAY_SINT16:
|
||||
DO_COMPARISON(int16);
|
||||
case BIGARRAY_UINT16:
|
||||
DO_COMPARISON(uint16);
|
||||
case BIGARRAY_INT32:
|
||||
DO_COMPARISON(int32);
|
||||
case BIGARRAY_INT64:
|
||||
#ifdef ARCH_INT64_TYPE
|
||||
DO_COMPARISON(int64);
|
||||
#else
|
||||
invalid_argument("Bigarray.compare: 64-bit int arrays not supported");
|
||||
#endif
|
||||
case BIGARRAY_CAML_INT:
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
DO_COMPARISON(long);
|
||||
default:
|
||||
Assert(0);
|
||||
return 0; /* should not happen */
|
||||
}
|
||||
#undef DO_COMPARISON
|
||||
}
|
||||
|
||||
/* Hashing of a bigarray */
|
||||
|
||||
static long bigarray_hash(value v)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(v);
|
||||
long num_elts, n, h;
|
||||
int i;
|
||||
|
||||
num_elts = 1;
|
||||
for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
|
||||
if (num_elts >= 50) num_elts = 50;
|
||||
h = 0;
|
||||
|
||||
#define COMBINE(h,v) ((h << 4) + h + (v))
|
||||
|
||||
switch (b->flags & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_SINT8:
|
||||
case BIGARRAY_UINT8: {
|
||||
unsigned char * p = b->data;
|
||||
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_SINT16:
|
||||
case BIGARRAY_UINT16: {
|
||||
unsigned short * p = b->data;
|
||||
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_FLOAT4:
|
||||
case BIGARRAY_INT32:
|
||||
#ifndef ARCH_SIXTYFOUR
|
||||
case BIGARRAY_CAML_INT:
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
#endif
|
||||
{
|
||||
uint32 * p = b->data;
|
||||
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_FLOAT8:
|
||||
case BIGARRAY_INT64:
|
||||
#ifdef ARCH_SIXTYFOUR
|
||||
case BIGARRAY_CAML_INT:
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
#endif
|
||||
#ifdef ARCH_SIXTYFOUR
|
||||
{
|
||||
unsigned long * p = b->data;
|
||||
for (n = 0; n < num_elts; n++) h = COMBINE(h, *p++);
|
||||
break;
|
||||
}
|
||||
#else
|
||||
{
|
||||
uint32 * p = b->data;
|
||||
for (n = 0; n < num_elts; n++) {
|
||||
#ifdef ARCH_BIG_ENDIAN
|
||||
h = COMBINE(h, p[1]); h = COMBINE(h, p[0]); p += 2;
|
||||
#else
|
||||
h = COMBINE(h, p[0]); h = COMBINE(h, p[1]); p += 2;
|
||||
#endif
|
||||
}
|
||||
break;
|
||||
}
|
||||
#endif
|
||||
}
|
||||
#undef COMBINE
|
||||
return h;
|
||||
}
|
||||
|
||||
static void bigarray_serialize_longarray(void * data,
|
||||
long num_elts,
|
||||
long min_val, long max_val)
|
||||
{
|
||||
#ifdef ARCH_SIXTYFOUR
|
||||
int overflow_32 = 0;
|
||||
long * p, n;
|
||||
for (n = 0, p = data; n < num_elts; n++, p++) {
|
||||
if (*p < min_val || *p > max_val) { overflow_32 = 1; break; }
|
||||
}
|
||||
if (overflow_32) {
|
||||
serialize_int_1(1);
|
||||
serialize_block_8(data, num_elts);
|
||||
} else {
|
||||
serialize_int_1(0);
|
||||
for (n = 0, p = data; n < num_elts; n++, p++) serialize_int_4((int32) *p);
|
||||
}
|
||||
#else
|
||||
serialize_int_1(0);
|
||||
serialize_block_4(data, num_elts);
|
||||
#endif
|
||||
}
|
||||
|
||||
static void bigarray_serialize(value v,
|
||||
unsigned long * wsize_32,
|
||||
unsigned long * wsize_64)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(v);
|
||||
long num_elts;
|
||||
int i;
|
||||
|
||||
/* Serialize header information */
|
||||
serialize_int_4(b->num_dims);
|
||||
serialize_int_4(b->flags);
|
||||
for (i = 0; i < b->num_dims; i++) serialize_int_4(b->dim[i]);
|
||||
/* Compute total number of elements */
|
||||
num_elts = 1;
|
||||
for (i = 0; i < b->num_dims; i++) num_elts = num_elts * b->dim[i];
|
||||
/* Serialize elements */
|
||||
switch (b->flags & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_SINT8:
|
||||
case BIGARRAY_UINT8:
|
||||
serialize_block_1(b->data, num_elts); break;
|
||||
case BIGARRAY_SINT16:
|
||||
case BIGARRAY_UINT16:
|
||||
serialize_block_2(b->data, num_elts); break;
|
||||
case BIGARRAY_FLOAT4:
|
||||
case BIGARRAY_INT32:
|
||||
serialize_block_4(b->data, num_elts); break;
|
||||
case BIGARRAY_FLOAT8:
|
||||
case BIGARRAY_INT64:
|
||||
serialize_block_8(b->data, num_elts); break;
|
||||
case BIGARRAY_CAML_INT:
|
||||
bigarray_serialize_longarray(b->data, num_elts, -0x40000000, 0x3FFFFFFF);
|
||||
break;
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
bigarray_serialize_longarray(b->data, num_elts, -0x80000000, 0x7FFFFFFF);
|
||||
break;
|
||||
}
|
||||
/* Compute required size in Caml heap. Assumes struct caml_bigarray
|
||||
is exactly 4 + num_dims words */
|
||||
Assert(sizeof(struct caml_bigarray) == 5 * sizeof(value));
|
||||
*wsize_32 = (4 + b->num_dims) * 4;
|
||||
*wsize_64 = (4 + b->num_dims) * 8;
|
||||
}
|
||||
|
||||
static void bigarray_deserialize_longarray(void * dest, long num_elts)
|
||||
{
|
||||
int sixty = deserialize_uint_1();
|
||||
#ifdef ARCH_SIXTYFOUR
|
||||
if (sixty) {
|
||||
deserialize_block_8(dest, num_elts);
|
||||
} else {
|
||||
long * p, n;
|
||||
for (n = 0, p = dest; n < num_elts; n++, p++) *p = deserialize_sint_4();
|
||||
}
|
||||
#else
|
||||
if (sixty)
|
||||
deserialize_error("input_value: cannot read bigarray "
|
||||
"with 64-bit Caml ints");
|
||||
deserialize_block_4(dest, num_elts);
|
||||
#endif
|
||||
}
|
||||
|
||||
unsigned long bigarray_deserialize(void * dst)
|
||||
{
|
||||
struct caml_bigarray * b = dst;
|
||||
int i, elt_size;
|
||||
long num_elts;
|
||||
|
||||
/* Read back header information */
|
||||
b->num_dims = deserialize_uint_4();
|
||||
b->flags = deserialize_uint_4();
|
||||
for (i = 0; i < b->num_dims; i++) b->dim[i] = deserialize_uint_4();
|
||||
/* Compute total number of elements */
|
||||
num_elts = bigarray_num_elts(b);
|
||||
/* Determine element size in bytes */
|
||||
if ((b->flags & BIGARRAY_KIND_MASK) > BIGARRAY_NATIVE_INT)
|
||||
deserialize_error("input_value: bad bigarray kind");
|
||||
elt_size = bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
|
||||
/* Allocate room for data */
|
||||
b->data = malloc(elt_size * num_elts);
|
||||
if (b->data == NULL)
|
||||
deserialize_error("input_value: out of memory for bigarray");
|
||||
/* Read data */
|
||||
switch (b->flags & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_SINT8:
|
||||
case BIGARRAY_UINT8:
|
||||
deserialize_block_1(b->data, num_elts); break;
|
||||
case BIGARRAY_SINT16:
|
||||
case BIGARRAY_UINT16:
|
||||
deserialize_block_2(b->data, num_elts); break;
|
||||
case BIGARRAY_FLOAT4:
|
||||
case BIGARRAY_INT32:
|
||||
deserialize_block_4(b->data, num_elts); break;
|
||||
case BIGARRAY_FLOAT8:
|
||||
case BIGARRAY_INT64:
|
||||
deserialize_block_8(b->data, num_elts); break;
|
||||
case BIGARRAY_CAML_INT:
|
||||
case BIGARRAY_NATIVE_INT:
|
||||
bigarray_deserialize_longarray(b->data, num_elts); break;
|
||||
}
|
||||
return sizeof(struct caml_bigarray) + (b->num_dims - 1) * sizeof(long);
|
||||
}
|
||||
|
||||
/* Operation table for bigarrays */
|
||||
|
||||
static struct custom_operations bigarray_ops = {
|
||||
"_bigarray",
|
||||
bigarray_finalize,
|
||||
bigarray_compare,
|
||||
bigarray_hash,
|
||||
bigarray_serialize,
|
||||
bigarray_deserialize
|
||||
};
|
||||
|
||||
/* Create / update proxy to indicate that b2 is a sub-array of b1 */
|
||||
|
||||
static void bigarray_update_proxy(struct caml_bigarray * b1,
|
||||
struct caml_bigarray * b2)
|
||||
{
|
||||
struct caml_bigarray_proxy * proxy;
|
||||
/* Nothing to do for un-managed arrays */
|
||||
if ((b1->flags & BIGARRAY_MANAGED_MASK) == BIGARRAY_EXTERNAL) return;
|
||||
if (b1->proxy != NULL) {
|
||||
/* If b1 is already a proxy for a larger array, increment refcount of
|
||||
proxy */
|
||||
b2->proxy = b1->proxy;
|
||||
++ b1->proxy->refcount;
|
||||
} else {
|
||||
/* Otherwise, create proxy and attach it to both b1 and b2 */
|
||||
proxy = stat_alloc(sizeof(struct caml_bigarray_proxy));
|
||||
proxy->refcount = 2; /* original array + sub array */
|
||||
proxy->data = b1->data;
|
||||
b1->proxy = proxy;
|
||||
b2->proxy = proxy;
|
||||
}
|
||||
}
|
||||
|
||||
/* Slicing */
|
||||
|
||||
value bigarray_slice(value vb, value vind)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
long index[MAX_NUM_DIMS];
|
||||
int num_inds, i;
|
||||
long offset;
|
||||
long * sub_dims;
|
||||
char * sub_data;
|
||||
value res;
|
||||
|
||||
/* Check number of indices < number of dimensions of array
|
||||
(maybe not necessary if ML typing guarantees this) */
|
||||
num_inds = Wosize_val(vind);
|
||||
if (num_inds >= b->num_dims)
|
||||
invalid_argument("Bigarray.slice: too many indices");
|
||||
/* Compute offset and check bounds */
|
||||
if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) {
|
||||
/* We slice from the left */
|
||||
for (i = 0; i < num_inds; i++) index[i] = Long_val(Field(vind, i));
|
||||
for (/*nothing*/; i < b->num_dims; i++) index[i] = 0;
|
||||
offset = bigarray_offset(b, index);
|
||||
sub_dims = b->dim + num_inds;
|
||||
} else {
|
||||
/* We slice from the right */
|
||||
for (i = 0; i < num_inds; i++)
|
||||
index[b->num_dims - num_inds + i] = Long_val(Field(vind, i));
|
||||
for (i = 0; i < b->num_dims - num_inds; i++) index[i] = 1;
|
||||
offset = bigarray_offset(b, index);
|
||||
sub_dims = b->dim;
|
||||
}
|
||||
sub_data =
|
||||
(char *) b->data +
|
||||
offset * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
|
||||
/* Allocate a Caml bigarray to hold the result */
|
||||
res = alloc_bigarray(b->flags, b->num_dims - num_inds, sub_data, sub_dims);
|
||||
/* Create or update proxy in case of managed bigarray */
|
||||
bigarray_update_proxy(b, Bigarray_val(res));
|
||||
/* Return result */
|
||||
return res;
|
||||
}
|
||||
|
||||
/* Extracting a sub-array of same number of dimensions */
|
||||
|
||||
value bigarray_sub(value vb, value vofs, value vlen)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
long ofs = Long_val(vofs);
|
||||
long len = Long_val(vlen);
|
||||
int i, changed_dim;
|
||||
long mul;
|
||||
char * sub_data;
|
||||
value res;
|
||||
|
||||
/* Compute offset and check bounds */
|
||||
if ((b->flags & BIGARRAY_LAYOUT_MASK) == BIGARRAY_C_LAYOUT) {
|
||||
/* We reduce the first dimension */
|
||||
mul = 1;
|
||||
for (i = 1; i < b->num_dims; i++) mul *= b->dim[i];
|
||||
changed_dim = 0;
|
||||
} else {
|
||||
/* We reduce the last dimension */
|
||||
mul = 1;
|
||||
for (i = 0; i < b->num_dims - 1; i++) mul *= b->dim[i];
|
||||
changed_dim = b->num_dims - 1;
|
||||
ofs--; /* Fortran arrays start at 1 */
|
||||
}
|
||||
if (ofs < 0 || len <= 0 || ofs + len > b->dim[changed_dim])
|
||||
invalid_argument("Bigarray.sub: bad sub-array");
|
||||
sub_data =
|
||||
(char *) b->data +
|
||||
ofs * mul * bigarray_element_size[b->flags & BIGARRAY_KIND_MASK];
|
||||
/* Allocate a Caml bigarray to hold the result */
|
||||
res = alloc_bigarray(b->flags, b->num_dims, sub_data, b->dim);
|
||||
/* Doctor the changed dimension */
|
||||
Bigarray_val(res)->dim[changed_dim] = len;
|
||||
/* Create or update proxy in case of managed bigarray */
|
||||
bigarray_update_proxy(b, Bigarray_val(res));
|
||||
/* Return result */
|
||||
return res;
|
||||
}
|
||||
|
||||
/* Copying a big array into another one */
|
||||
|
||||
value bigarray_blit(value vsrc, value vdst)
|
||||
{
|
||||
struct caml_bigarray * src = Bigarray_val(vsrc);
|
||||
struct caml_bigarray * dst = Bigarray_val(vdst);
|
||||
int i;
|
||||
long 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 =
|
||||
bigarray_num_elts(src)
|
||||
* bigarray_element_size[src->flags & BIGARRAY_KIND_MASK];
|
||||
/* Do the copying */
|
||||
bcopy(src->data, dst->data, num_bytes);
|
||||
return Val_unit;
|
||||
blit_error:
|
||||
invalid_argument("Bigarray.blit: dimension mismatch");
|
||||
return Val_unit; /* not reached */
|
||||
}
|
||||
|
||||
/* Filling a big array with a given value */
|
||||
|
||||
value bigarray_fill(value vb, value vinit)
|
||||
{
|
||||
struct caml_bigarray * b = Bigarray_val(vb);
|
||||
long num_elts = bigarray_num_elts(b);
|
||||
|
||||
switch (b->flags & BIGARRAY_KIND_MASK) {
|
||||
case BIGARRAY_FLOAT4: {
|
||||
float init = Double_val(vinit);
|
||||
float * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_FLOAT8: {
|
||||
double init = Double_val(vinit);
|
||||
double * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_SINT8:
|
||||
case BIGARRAY_UINT8: {
|
||||
int init = Int_val(vinit);
|
||||
char * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_SINT16:
|
||||
case BIGARRAY_UINT16: {
|
||||
int init = Int_val(vinit);
|
||||
short * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_INT32: {
|
||||
int32 init = Int32_val(vinit);
|
||||
int32 * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_INT64: {
|
||||
int64 init = Int64_val(vinit);
|
||||
int64 * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
case BIGARRAY_NATIVE_INT: {
|
||||
long init = Nativeint_val(vinit);
|
||||
long * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
default:
|
||||
Assert(0);
|
||||
case BIGARRAY_CAML_INT: {
|
||||
long init = Long_val(vinit);
|
||||
long * p;
|
||||
for (p = b->data; num_elts > 0; p++, num_elts--) *p = init;
|
||||
break;
|
||||
}
|
||||
}
|
||||
return Val_unit;
|
||||
}
|
||||
Loading…
Reference in New Issue