Skip to content

Commit

Permalink
Merge pull request #523 from yallop/fortran-bigarrays
Browse files Browse the repository at this point in the history 
Support for Fortran-layout bigarrays
  • Loading branch information
@yallop
yallop authored May 22, 2017
2 parents 048b81a + 2f4592d commit f8d3e22
Show file tree
Hide file tree
Showing 12 changed files with 240 additions and 89 deletions.
2 changes: 1 addition & 1 deletion src/cstubs/cstubs_analysis.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -55,7 +55,7 @@ type _ alloc =
| Alloc_funptr : _ static_funptr alloc
| Alloc_structured : (_, _) structured alloc
| Alloc_array : _ carray alloc
| Alloc_bigarray : (_, 'a) Ctypes_bigarray.t -> 'a alloc
| Alloc_bigarray : (_, 'a, _) Ctypes_bigarray.t -> 'a alloc
| Alloc_view : ('a, 'b) view * 'b alloc -> 'a alloc

type 'a allocation = [ `Noalloc of 'a noalloc | `Alloc of 'a alloc ]
Expand Down
2 changes: 1 addition & 1 deletion src/cstubs/cstubs_internals.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -41,7 +41,7 @@ type 'a typ = 'a Ctypes_static.typ =
| Abstract : Ctypes_static.abstract_type -> 'a Ctypes_static.abstract typ
| View : ('a, 'b) view -> 'a typ
| Array : 'a typ * int -> 'a Ctypes_static.carray typ
| Bigarray : (_, 'a) Ctypes_bigarray.t -> 'a typ
| Bigarray : (_, 'a, _) Ctypes_bigarray.t -> 'a typ
| OCaml : 'a ocaml_type -> 'a ocaml typ
and ('a, 'b) pointer = ('a, 'b) Ctypes_static.pointer =
CPointer : 'a typ Ctypes_ptr.Fat.t -> ('a, [`C]) pointer
Expand Down
38 changes: 29 additions & 9 deletions src/ctypes/ctypes.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,32 +46,36 @@ type 'a bigarray_class = 'a Ctypes_static.bigarray_class

val genarray :
< element: 'a;
layout: 'l;
ba_repr: 'b;
bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t;
bigarray: ('a, 'b, 'l) Bigarray.Genarray.t;
carray: 'a carray;
dims: int array > bigarray_class
(** The class of {!Bigarray.Genarray.t} values *)

val array1 :
< element: 'a;
layout: 'l;
ba_repr: 'b;
bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t;
bigarray: ('a, 'b, 'l) Bigarray.Array1.t;
carray: 'a carray;
dims: int > bigarray_class
(** The class of {!Bigarray.Array1.t} values *)

val array2 :
< element: 'a;
layout: 'l;
ba_repr: 'b;
bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t;
bigarray: ('a, 'b, 'l) Bigarray.Array2.t;
carray: 'a carray carray;
dims: int * int > bigarray_class
(** The class of {!Bigarray.Array2.t} values *)

val array3 :
< element: 'a;
layout: 'l;
ba_repr: 'b;
bigarray: ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t;
bigarray: ('a, 'b, 'l) Bigarray.Array3.t;
carray: 'a carray carray carray;
dims: int * int * int > bigarray_class
(** The class of {!Bigarray.Array3.t} values *)
Expand Down Expand Up @@ -338,23 +342,37 @@ end
(** {4 Bigarray values} *)

val bigarray_start : < element: 'a;
layout: 'l;
ba_repr: _;
bigarray: 'b;
carray: _;
dims: _ > bigarray_class -> 'b -> 'a ptr
(** Return the address of the first element of the given Bigarray value. *)

val bigarray_of_ptr : < element: 'a;
layout: Bigarray.c_layout;
ba_repr: 'f;
bigarray: 'b;
carray: _;
dims: 'i > bigarray_class ->
'i -> ('a, 'f) Bigarray.kind -> 'a ptr -> 'b
(** [bigarray_of_ptr c dims k p] converts the C pointer [p] to a bigarray
value. No copy is made; the bigarray references the memory pointed to by
[p]. *)
(** [bigarray_of_ptr c dims k p] converts the C pointer [p] to a C-layout
bigarray value. No copy is made; the bigarray references the memory
pointed to by [p]. *)

val fortran_bigarray_of_ptr : < element: 'a;
layout: Bigarray.fortran_layout;
ba_repr: 'f;
bigarray: 'b;
carray: _;
dims: 'i > bigarray_class ->
'i -> ('a, 'f) Bigarray.kind -> 'a ptr -> 'b
(** [fortran_bigarray_of_ptr c dims k p] converts the C pointer [p] to a
Fortran-layout bigarray value. No copy is made; the bigarray references
the memory pointed to by [p]. *)

val array_of_bigarray : < element: _;
layout: Bigarray.c_layout;
ba_repr: _;
bigarray: 'b;
carray: 'c;
Expand All @@ -366,13 +384,15 @@ val array_of_bigarray : < element: _;
(** Convert a Bigarray value to a C array. *)

val bigarray_of_array : < element: 'a;
layout: Bigarray.c_layout;
ba_repr: 'f;
bigarray: 'b;
carray: 'c carray;
dims: 'i > bigarray_class ->
('a, 'f) Bigarray.kind -> 'c carray -> 'b
(** [bigarray_of_array c k a] converts the {!CArray.t} value [a] to a bigarray
value. No copy is made; the result occupies the same memory as [a]. *)
(** [bigarray_of_array c k a] converts the {!CArray.t} value [a] to a
C-layout bigarray value. No copy is made; the result occupies the
same memory as [a]. *)

(** {3 Struct and union values} *)

Expand Down
67 changes: 38 additions & 29 deletions src/ctypes/ctypes_bigarray.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -27,39 +27,39 @@ let bigarray_kind_sizeof k = Ctypes_primitives.sizeof (prim_of_kind k)

let bigarray_kind_alignment k = Ctypes_primitives.alignment (prim_of_kind k)

type (_, _) dims =
| DimsGen : int array -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Genarray.t) dims
| Dims1 : int -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Array1.t) dims
| Dims2 : int * int -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Array2.t) dims
| Dims3 : int * int * int -> ('a, ('a, _, Bigarray.c_layout) Bigarray.Array3.t) dims
type (_, _, _) dims =
| DimsGen : int array -> ('a, ('a, _, 'l) Bigarray.Genarray.t, 'l) dims
| Dims1 : int -> ('a, ('a, _, 'l) Bigarray.Array1.t, 'l) dims
| Dims2 : int * int -> ('a, ('a, _, 'l) Bigarray.Array2.t, 'l) dims
| Dims3 : int * int * int -> ('a, ('a, _, 'l) Bigarray.Array3.t, 'l) dims

type ('a, 'b) t = ('a, 'b) dims * 'a kind
type ('a, 'b, 'l) t = ('a, 'b, 'l) dims * 'a kind * 'l Bigarray.layout

let elements : type a b. (b, a) dims -> int = function
let elements : type a b l. (b, a, l) dims -> int = function
| DimsGen ds -> Array.fold_left ( * ) 1 ds
| Dims1 d -> d
| Dims2 (d1, d2) -> d1 * d2
| Dims3 (d1, d2, d3) -> d1 * d2 * d3

let element_type (_, k) = prim_of_kind k
let element_type (_, k, _) = prim_of_kind k

let dimensions : type a b. (b, a) t -> int array = function
| DimsGen dims, _ -> dims
| Dims1 x, _ -> [| x |]
| Dims2 (x, y), _ -> [| x; y |]
| Dims3 (x, y, z), _ -> [| x; y; z |]
let dimensions : type a b l. (b, a, l) t -> int array = function
| DimsGen dims, _, _ -> dims
| Dims1 x, _, _ -> [| x |]
| Dims2 (x, y), _, _ -> [| x; y |]
| Dims3 (x, y, z), _, _ -> [| x; y; z |]

let sizeof (d, k) = elements d * bigarray_kind_sizeof k
let sizeof (d, k, _) = elements d * bigarray_kind_sizeof k

let alignment (d, k) = bigarray_kind_alignment k
let alignment (_, k, _) = bigarray_kind_alignment k

let bigarray ds k = (DimsGen ds, kind k)
let bigarray1 d k = (Dims1 d, kind k)
let bigarray2 d1 d2 k = (Dims2 (d1, d2), kind k)
let bigarray3 d1 d2 d3 k = (Dims3 (d1, d2, d3), kind k)
let bigarray ds k l = (DimsGen ds, kind k, l)
let bigarray1 d k l = (Dims1 d, kind k, l)
let bigarray2 d1 d2 k l = (Dims2 (d1, d2), kind k, l)
let bigarray3 d1 d2 d3 k l = (Dims3 (d1, d2, d3), kind k, l)

let path_of_string = Ctypes_path.path_of_string
let type_name : type a b. (b, a) dims -> Ctypes_path.path = function
let type_name : type a b l. (b, a, l) dims -> Ctypes_path.path = function
| DimsGen _ -> path_of_string "Bigarray.Genarray.t"
| Dims1 _ -> path_of_string "Bigarray.Array1.t"
| Dims2 _ -> path_of_string "Bigarray.Array2.t"
Expand Down Expand Up @@ -106,11 +106,20 @@ let kind_type_names : type a. a kind -> _ = function
(`Ident (path_of_string "char"),
`Ident (path_of_string "Bigarray.int8_unsigned_elt"))

let type_expression : type a b. (a, b) t -> _ =
fun (t, ck) ->
(** OCaml-4.01-compatible comparison. This can be replaced with
pattern matching once ctypes requires OCaml 4.02 *)
type boxed_layout = Boxed_layout : _ Bigarray.layout -> boxed_layout
let layout_path : type a. a Bigarray.layout -> Ctypes_path.path =
fun layout ->
if Boxed_layout layout = Boxed_layout Bigarray.c_layout
then path_of_string "Bigarray.c_layout"
else path_of_string "Bigarray.fortran_layout"

let type_expression : type a b l. (a, b, l) t -> _ =
fun (t, ck, l) ->
begin
let a, b = kind_type_names ck in
let layout = `Ident (path_of_string "Bigarray.c_layout") in
let layout = `Ident (layout_path l) in
(`Appl (type_name t, [a; b; layout])
: [> `Ident of Ctypes_path.path
| `Appl of Ctypes_path.path * 'a list ] as 'a)
Expand All @@ -120,13 +129,13 @@ let prim_of_kind k = prim_of_kind (kind k)

let unsafe_address b = Ctypes_bigarray_stubs.address b

let view : type a b. (a, b) t -> _ Ctypes_ptr.Fat.t -> b =
let view : type a b l. (a, b, l) t -> _ Ctypes_ptr.Fat.t -> b =
let open Ctypes_bigarray_stubs in
fun (dims, kind) ptr -> let ba : b = match dims with
| DimsGen ds -> view kind ~dims:ds ptr
| Dims1 d -> view1 kind ~dims:[| d |] ptr
| Dims2 (d1, d2) -> view2 kind ~dims:[| d1; d2 |] ptr
| Dims3 (d1, d2, d3) -> view3 kind ~dims:[| d1; d2; d3 |] ptr in
fun (dims, kind, layout) ptr -> let ba : b = match dims with
| DimsGen ds -> view kind ~dims:ds ptr layout
| Dims1 d -> view1 kind ~dims:[| d |] ptr layout
| Dims2 (d1, d2) -> view2 kind ~dims:[| d1; d2 |] ptr layout
| Dims3 (d1, d2, d3) -> view3 kind ~dims:[| d1; d2; d3 |] ptr layout in
match Ctypes_ptr.Fat.managed ptr with
| None -> ba
| Some src -> Gc.finalise (fun _ -> Ctypes_memory_stubs.use_value src) ba; ba
34 changes: 17 additions & 17 deletions src/ctypes/ctypes_bigarray.mli
View file
Original file line number Diff line number Diff line change
Expand Up @@ -7,47 +7,47 @@

(** {2 Types} *)

type ('a, 'b) t
type ('a, 'b, 'l) t
(** The type of bigarray values of particular sizes. A value of type
[(a, b) t] can be used to read and write values of type [b]. *)
[(a, b, l) t] can be used to read and write values of type [b]. *)

(** {3 Type constructors} *)

val bigarray : int array -> ('a, 'b) Bigarray.kind ->
('a, ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t) t
val bigarray : int array -> ('a, 'b) Bigarray.kind -> 'l Bigarray.layout ->
('a, ('a, 'b, 'l) Bigarray.Genarray.t, 'l) t
(** Create a {!t} value for the {!Bigarray.Genarray.t} type. *)

val bigarray1 : int -> ('a, 'b) Bigarray.kind ->
('a, ('a, 'b, Bigarray.c_layout) Bigarray.Array1.t) t
val bigarray1 : int -> ('a, 'b) Bigarray.kind -> 'l Bigarray.layout ->
('a, ('a, 'b, 'l) Bigarray.Array1.t, 'l) t
(** Create a {!t} value for the {!Bigarray.Array1.t} type. *)

val bigarray2 : int -> int -> ('a, 'b) Bigarray.kind ->
('a, ('a, 'b, Bigarray.c_layout) Bigarray.Array2.t) t
val bigarray2 : int -> int -> ('a, 'b) Bigarray.kind -> 'l Bigarray.layout ->
('a, ('a, 'b, 'l) Bigarray.Array2.t, 'l) t
(** Create a {!t} value for the {!Bigarray.Array2.t} type. *)

val bigarray3 : int -> int -> int -> ('a, 'b) Bigarray.kind ->
('a, ('a, 'b, Bigarray.c_layout) Bigarray.Array3.t) t
val bigarray3 : int -> int -> int -> ('a, 'b) Bigarray.kind -> 'l Bigarray.layout ->
('a, ('a, 'b, 'l) Bigarray.Array3.t, 'l) t
(** Create a {!t} value for the {!Bigarray.Array3.t} type. *)

val prim_of_kind : ('a, _) Bigarray.kind -> 'a Ctypes_primitive_types.prim
(** Create a {!Ctypes_ptr.Types.ctype} for a {!Bigarray.kind}. *)

(** {3 Type eliminators} *)

val sizeof : (_, _) t -> int
val sizeof : (_, _, _) t -> int
(** Compute the size of a bigarray type. *)

val alignment : (_, _) t -> int
val alignment : (_, _, _) t -> int
(** Compute the alignment of a bigarray type. *)

val element_type : ('a, _) t -> 'a Ctypes_primitive_types.prim
val element_type : ('a, _, _) t -> 'a Ctypes_primitive_types.prim
(** Compute the element type of a bigarray type. *)

val dimensions : (_, _) t -> int array
val dimensions : (_, _, _) t -> int array
(** Compute the dimensions of a bigarray type. *)

val type_expression : ('a, 'b) t -> ([> `Appl of Ctypes_path.path * 'c list
| `Ident of Ctypes_path.path ] as 'c)
val type_expression : ('a, 'b, 'l) t -> ([> `Appl of Ctypes_path.path * 'c list
| `Ident of Ctypes_path.path ] as 'c)
(** Compute a type expression that denotes a bigarray type. *)

(** {2 Values} *)
Expand All @@ -59,7 +59,7 @@ val unsafe_address : 'a -> Ctypes_ptr.voidp
reference to the OCaml object then the array might be freed, invalidating
the address. *)

val view : (_, 'a) t -> _ Ctypes_ptr.Fat.t -> 'a
val view : (_, 'a, _) t -> _ Ctypes_ptr.Fat.t -> 'a
(** [view b ptr] creates a bigarray view onto existing memory.
If [ptr] references an OCaml object then [view] will ensure that
Expand Down
8 changes: 4 additions & 4 deletions src/ctypes/ctypes_bigarray_stubs.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -34,17 +34,17 @@ external address : 'b -> Ctypes_ptr.voidp
= "ctypes_bigarray_address"

external view : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t ->
('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t
'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Genarray.t
= "ctypes_bigarray_view"

external view1 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t ->
('a, 'b, Bigarray.c_layout) Bigarray.Array1.t
'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Array1.t
= "ctypes_bigarray_view"

external view2 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t ->
('a, 'b, Bigarray.c_layout) Bigarray.Array2.t
'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Array2.t
= "ctypes_bigarray_view"

external view3 : 'a kind -> dims:int array -> _ Ctypes_ptr.Fat.t ->
('a, 'b, Bigarray.c_layout) Bigarray.Array3.t
'l Bigarray.layout -> ('a, 'b, 'l) Bigarray.Array3.t
= "ctypes_bigarray_view"
17 changes: 13 additions & 4 deletions src/ctypes/ctypes_bigarrays.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -10,24 +10,33 @@

#include "ctypes_raw_pointer.h"

#ifndef Caml_ba_layout_val
/* Caml_ba_layout_val was introduced when the representation of layout
values changed from an integer to a GADT. Up to that point the
OCaml values c_layout and fortran_layout had the same values as
the C constants CAML_BA_C_LAYOUT and CAML_BA_FORTRAN_LAYOUT */
#define Caml_ba_layout_val(v) (Int_val(v))
#endif

/* address : 'b -> pointer */
value ctypes_bigarray_address(value ba)
{
return CTYPES_FROM_PTR(Caml_ba_data_val(ba));
}

/* _view : ('a, 'b) kind -> dims:int array -> fatptr ->
('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t */
value ctypes_bigarray_view(value kind_, value dims_, value ptr_)
/* _view : ('a, 'b) kind -> dims:int array -> fatptr -> 'l layout ->
('a, 'b, 'l) Bigarray.Genarray.t */
value ctypes_bigarray_view(value kind_, value dims_, value ptr_, value layout_)
{
int kind = Int_val(kind_);
int layout = Caml_ba_layout_val(layout_);
int ndims = Wosize_val(dims_);
intnat dims[CAML_BA_MAX_NUM_DIMS];
int i;
for (i = 0; i < ndims; i++) {
dims[i] = Long_val(Field(dims_, i));
}
int flags = kind | CAML_BA_C_LAYOUT | CAML_BA_EXTERNAL;
int flags = kind | layout | CAML_BA_EXTERNAL;
void *data = CTYPES_ADDR_OF_FATPTR(ptr_);
return caml_ba_alloc(flags, ndims, data, dims);
}
13 changes: 10 additions & 3 deletions src/ctypes/ctypes_memory.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -283,8 +283,9 @@ let _bigarray_start kind ba =
let reftyp = Primitive (Ctypes_bigarray.prim_of_kind kind) in
CPointer (Fat.make ~managed:ba ~reftyp raw_address)

let bigarray_kind : type a b c d f.
let bigarray_kind : type a b c d f l.
< element: a;
layout: l;
ba_repr: f;
bigarray: b;
carray: c;
Expand All @@ -299,6 +300,7 @@ let bigarray_start spec ba = _bigarray_start (bigarray_kind spec ba) ba

let array_of_bigarray : type a b c d e.
< element: a;
layout: Bigarray.c_layout;
ba_repr: e;
bigarray: b;
carray: c;
Expand All @@ -320,8 +322,9 @@ let array_of_bigarray : type a b c d e.
let d1 = Array3.dim1 ba and d2 = Array3.dim2 ba and d3 = Array3.dim3 ba in
CArray.from_ptr (castp (array d2 (array d3 (Fat.reftype p))) element_ptr) d1

let bigarray_elements : type a b c d f.
let bigarray_elements : type a b c d f l.
< element: a;
layout: l;
ba_repr: f;
bigarray: b;
carray: c;
Expand All @@ -335,8 +338,12 @@ let bigarray_elements : type a b c d f.
let bigarray_of_ptr spec dims kind ptr =
!@ (castp (bigarray spec dims kind) ptr)

let array_dims : type a b c d f.
let fortran_bigarray_of_ptr spec dims kind ptr =
!@ (castp (fortran_bigarray spec dims kind) ptr)

let array_dims : type a b c d f l.
< element: a;
layout: l;
ba_repr: f;
bigarray: b;
carray: c carray;
Expand Down
Loading

0 comments on commit f8d3e22

Please sign in to comment.