Source file ctypes_bigarray.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
open Ctypes_bigarray_stubs
let prim_of_kind : type a. a kind -> a Ctypes_primitive_types.prim
= let open Ctypes_primitive_types in function
Kind_float32 -> Float
| Kind_float64 -> Double
| Kind_int8_signed -> Int8_t
| Kind_int8_unsigned -> Int8_t
| Kind_int16_signed -> Int16_t
| Kind_int16_unsigned -> Int16_t
| Kind_int32 -> Int32_t
| Kind_int64 -> Int64_t
| Kind_int -> Camlint
| Kind_nativeint -> Nativeint
| Kind_complex32 -> Complex32
| Kind_complex64 -> Complex64
| Kind_char -> Char
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, _, 'l) Bigarray_compat.Genarray.t, 'l) dims
| Dims1 : int -> ('a, ('a, _, 'l) Bigarray_compat.Array1.t, 'l) dims
| Dims2 : int * int -> ('a, ('a, _, 'l) Bigarray_compat.Array2.t, 'l) dims
| Dims3 : int * int * int -> ('a, ('a, _, 'l) Bigarray_compat.Array3.t, 'l) dims
type ('a, 'b, 'l) t = ('a, 'b, 'l) dims * 'a kind * 'l Bigarray_compat.layout
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 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 alignment (_, k, _) = bigarray_kind_alignment 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 type_name : type a b l. (b, a, l) dims -> string list = function
| DimsGen _ -> ["Bigarray"; "Genarray"; "t"]
| Dims1 _ -> ["Bigarray"; "Array1"; "t"]
| Dims2 _ -> ["Bigarray"; "Array2"; "t"]
| Dims3 _ -> ["Bigarray"; "Array3"; "t"]
let kind_type_names : type a. a kind -> _ = function
| Kind_float32 ->
(`Ident ["float"],
`Ident ["Bigarray"; "float32_elt"])
| Kind_float64 ->
(`Ident ["float"],
`Ident ["Bigarray"; "float64_elt"])
| Kind_int8_signed ->
(`Ident ["int"],
`Ident ["Bigarray"; "int8_signed_elt"])
| Kind_int8_unsigned ->
(`Ident ["int"],
`Ident ["Bigarray"; "int8_unsigned_elt"])
| Kind_int16_signed ->
(`Ident ["int"],
`Ident ["Bigarray"; "int16_signed_elt"])
| Kind_int16_unsigned ->
(`Ident ["int"],
`Ident ["Bigarray"; "int16_unsigned_elt"])
| Kind_int32 ->
(`Ident ["int32"],
`Ident ["Bigarray"; "int32_elt"])
| Kind_int64 ->
(`Ident ["int64"],
`Ident ["Bigarray"; "int64_elt"])
| Kind_int ->
(`Ident ["int"],
`Ident ["Bigarray"; "int_elt"])
| Kind_nativeint ->
(`Ident ["nativeint"],
`Ident ["Bigarray"; "nativeint_elt"])
| Kind_complex32 ->
(`Ident ["Complex"; "t"],
`Ident ["Bigarray"; "complex32_elt"])
| Kind_complex64 ->
(`Ident ["Complex"; "t"],
`Ident ["Bigarray"; "complex64_elt"])
| Kind_char ->
(`Ident ["char"],
`Ident ["Bigarray"; "int8_unsigned_elt"])
let layout_path : type a. a Bigarray_compat.layout -> string list =
function
| Bigarray_compat.C_layout -> ["Bigarray"; "c_layout"]
| Bigarray_compat.Fortran_layout -> ["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 (layout_path l) in
(`Appl (type_name t, [a; b; layout]))
end
let prim_of_kind k = prim_of_kind (kind k)
let unsafe_address b = Ctypes_bigarray_stubs.address b
let view : type a b l m. (a, b, l) t -> (m option, _) Ctypes_ptr.Fat.t -> b =
let open Ctypes_bigarray_stubs 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