diff --git a/CHANGES.md b/CHANGES.md index fd157079dd..8ffd45871f 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -14,6 +14,7 @@ * Runtime: change Sys.os_type on windows (Cygwin -> Win32) * Runtime: backtraces are really expensive, they need to be be explicitly requested at compile time (--enable with-js-error) or at startup (OCAMLRUNPARAM=b=1) +* Lib: Modify Typed_array API for compatibility with WebAssembly ## Bug fixes diff --git a/lib/js_of_ocaml/typed_array.ml b/lib/js_of_ocaml/typed_array.ml index f0bd32f2aa..75afe885f6 100644 --- a/lib/js_of_ocaml/typed_array.ml +++ b/lib/js_of_ocaml/typed_array.ml @@ -20,8 +20,6 @@ open! Import open Js -type uint32 = float - class type arrayBuffer = object method byteLength : int readonly_prop @@ -40,7 +38,7 @@ class type arrayBufferView = object method byteLength : int readonly_prop end -class type ['a, 'b] typedArray = object +class type ['a, 'b, 'c] typedArray = object inherit arrayBufferView method _BYTES_PER_ELEMENT : int readonly_prop @@ -49,47 +47,60 @@ class type ['a, 'b] typedArray = object method set_fromArray : 'a js_array t -> int -> unit meth - method set_fromTypedArray : ('a, 'b) typedArray t -> int -> unit meth + method set_fromTypedArray : ('a, 'b, 'c) typedArray t -> int -> unit meth - method subarray : int -> int -> ('a, 'b) typedArray t meth + method subarray : int -> int -> ('a, 'b, 'c) typedArray t meth - method subarray_toEnd : int -> ('a, 'b) typedArray t meth + method subarray_toEnd : int -> ('a, 'b, 'c) typedArray t meth - method slice : int -> int -> ('a, 'b) typedArray t meth + method slice : int -> int -> ('a, 'b, 'c) typedArray t meth - method slice_toEnd : int -> ('a, 'b) typedArray t meth + method slice_toEnd : int -> ('a, 'b, 'c) typedArray t meth (* This fake method is needed for typing purposes. Without it, ['b] would not be constrained. *) - method _content_type_ : 'b optdef readonly_prop + method _content_type_ : ('b * 'c) optdef readonly_prop end -type int8Array = (int, Bigarray.int8_signed_elt) typedArray +type int8Array = (int, int, Bigarray.int8_signed_elt) typedArray + +type uint8Array = (int, int, Bigarray.int8_unsigned_elt) typedArray -type uint8Array = (int, Bigarray.int8_unsigned_elt) typedArray +type int16Array = (int, int, Bigarray.int16_signed_elt) typedArray -type int16Array = (int, Bigarray.int16_signed_elt) typedArray +type uint16Array = (int, int, Bigarray.int16_unsigned_elt) typedArray -type uint16Array = (int, Bigarray.int16_unsigned_elt) typedArray +type int32Array = (number_t, Int32.t, Bigarray.int32_elt) typedArray -type int32Array = (int32, Bigarray.int32_elt) typedArray +type uint32Array = (number_t, Int32.t, Bigarray.int32_elt) typedArray -type uint32Array = (int32, Bigarray.int32_elt) typedArray +type float32Array = (number_t, float, Bigarray.float32_elt) typedArray -type float32Array = (float, Bigarray.float32_elt) typedArray +type float64Array = (number_t, float, Bigarray.float64_elt) typedArray -type float64Array = (float, Bigarray.float64_elt) typedArray +type (_, _, _) kind = + | Int8_signed : (int, int, Bigarray.int8_signed_elt) kind + | Int8_unsigned : (int, int, Bigarray.int8_unsigned_elt) kind + | Int16_signed : (int, int, Bigarray.int16_signed_elt) kind + | Int16_unsigned : (int, int, Bigarray.int16_unsigned_elt) kind + | Int32_signed : (number_t, Int32.t, Bigarray.int32_elt) kind + | Int32_unsigned : (number_t, Int32.t, Bigarray.int32_elt) kind + | Float32 : (number_t, float, Bigarray.float32_elt) kind + | Float64 : (number_t, float, Bigarray.float64_elt) kind -external kind : ('a, 'b) typedArray t -> ('a, 'b) Bigarray.kind +external kind : + ('typed_array, 'bigarray, 'elt) typedArray t -> ('bigarray, 'elt) Bigarray.kind = "caml_ba_kind_of_typed_array" -external from_genarray : - ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t -> ('a, 'b) typedArray t - = "caml_ba_to_typed_array" +external from_genarray_impl : + ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t + -> ('typed_array, 'bigarray, 'elt) typedArray t = "caml_ba_to_typed_array" external to_genarray : - ('a, 'b) typedArray t -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t - = "caml_ba_from_typed_array" + ('typed_array, 'bigarray, 'elt) typedArray t + -> ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t = "caml_ba_from_typed_array" + +let from_genarray (_ : ('typed_array, 'bigarray, 'elt) kind) a = from_genarray_impl a let int8Array = Js.Unsafe.global##._Int8Array @@ -171,12 +182,12 @@ let float64Array_fromBuffer = float64Array let float64Array_inBuffer = float64Array -let set : ('a, 'b) typedArray t -> int -> 'a -> unit = +let set : ('a, _, _) typedArray t -> int -> 'a -> unit = fun a i v -> array_set (Unsafe.coerce a) i v -let get : ('a, 'b) typedArray t -> int -> 'a optdef = fun a i -> Js.Unsafe.get a i +let get : ('a, _, _) typedArray t -> int -> 'a optdef = fun a i -> Js.Unsafe.get a i -let unsafe_get : ('a, 'b) typedArray t -> int -> 'a = fun a i -> Js.Unsafe.get a i +let unsafe_get : ('a, _, _) typedArray t -> int -> 'a = fun a i -> Js.Unsafe.get a i class type dataView = object inherit arrayBufferView @@ -193,13 +204,13 @@ class type dataView = object method getUint16_ : int -> bool t -> int meth - method getInt32 : int -> int meth + method getInt32 : int -> number_t meth - method getInt32_ : int -> bool t -> int meth + method getInt32_ : int -> bool t -> number_t meth - method getUint32 : int -> uint32 meth + method getUint32 : int -> number_t meth - method getUint32_ : int -> bool t -> uint32 meth + method getUint32_ : int -> bool t -> number_t meth method getFloat32 : int -> number_t meth @@ -221,13 +232,13 @@ class type dataView = object method setUint16_ : int -> int -> bool t -> unit meth - method setInt32 : int -> int -> unit meth + method setInt32 : int -> number_t -> unit meth - method setInt32_ : int -> int -> bool t -> unit meth + method setInt32_ : int -> number_t -> bool t -> unit meth - method setUint32 : int -> uint32 -> unit meth + method setUint32 : int -> number_t -> unit meth - method setUint32_ : int -> uint32 -> bool t -> unit meth + method setUint32_ : int -> number_t -> bool t -> unit meth method setFloat32 : int -> number_t -> unit meth diff --git a/lib/js_of_ocaml/typed_array.mli b/lib/js_of_ocaml/typed_array.mli index 21c80fb6fd..7ce5810263 100644 --- a/lib/js_of_ocaml/typed_array.mli +++ b/lib/js_of_ocaml/typed_array.mli @@ -22,8 +22,6 @@ open Js -type uint32 = float - class type arrayBuffer = object method byteLength : int readonly_prop @@ -42,7 +40,7 @@ class type arrayBufferView = object method byteLength : int readonly_prop end -class type ['a, 'b] typedArray = object +class type ['a, 'b, 'c] typedArray = object inherit arrayBufferView method _BYTES_PER_ELEMENT : int readonly_prop @@ -51,41 +49,61 @@ class type ['a, 'b] typedArray = object method set_fromArray : 'a js_array t -> int -> unit meth - method set_fromTypedArray : ('a, 'b) typedArray t -> int -> unit meth + method set_fromTypedArray : ('a, 'b, 'c) typedArray t -> int -> unit meth - method subarray : int -> int -> ('a, 'b) typedArray t meth + method subarray : int -> int -> ('a, 'b, 'c) typedArray t meth - method subarray_toEnd : int -> ('a, 'b) typedArray t meth + method subarray_toEnd : int -> ('a, 'b, 'c) typedArray t meth - method slice : int -> int -> ('a, 'b) typedArray t meth + method slice : int -> int -> ('a, 'b, 'c) typedArray t meth - method slice_toEnd : int -> ('a, 'b) typedArray t meth + method slice_toEnd : int -> ('a, 'b, 'c) typedArray t meth - method _content_type_ : 'b optdef readonly_prop + (* This fake method is needed for typing purposes. Without it, ['b] would not + be constrained. *) + method _content_type_ : ('b * 'c) optdef readonly_prop end -type int8Array = (int, Bigarray.int8_signed_elt) typedArray +type int8Array = (int, int, Bigarray.int8_signed_elt) typedArray + +type uint8Array = (int, int, Bigarray.int8_unsigned_elt) typedArray -type uint8Array = (int, Bigarray.int8_unsigned_elt) typedArray +type int16Array = (int, int, Bigarray.int16_signed_elt) typedArray -type int16Array = (int, Bigarray.int16_signed_elt) typedArray +type uint16Array = (int, int, Bigarray.int16_unsigned_elt) typedArray -type uint16Array = (int, Bigarray.int16_unsigned_elt) typedArray +type int32Array = (number_t, Int32.t, Bigarray.int32_elt) typedArray -type int32Array = (int32, Bigarray.int32_elt) typedArray +type uint32Array = (number_t, Int32.t, Bigarray.int32_elt) typedArray -type uint32Array = (int32, Bigarray.int32_elt) typedArray +type float32Array = (number_t, float, Bigarray.float32_elt) typedArray -type float32Array = (float, Bigarray.float32_elt) typedArray +type float64Array = (number_t, float, Bigarray.float64_elt) typedArray -type float64Array = (float, Bigarray.float64_elt) typedArray +(** The first type parameter is the type of values that can be read and written + in the {!classtype:typedArray}. The last two type parameters define the + kind of bigarrays that can be converted to and from the + {!classtype:typedArray}. See {!type:Bigarray.kind}. *) +type (_, _, _) kind = + | Int8_signed : (int, int, Bigarray.int8_signed_elt) kind + | Int8_unsigned : (int, int, Bigarray.int8_unsigned_elt) kind + | Int16_signed : (int, int, Bigarray.int16_signed_elt) kind + | Int16_unsigned : (int, int, Bigarray.int16_unsigned_elt) kind + | Int32_signed : (number_t, Int32.t, Bigarray.int32_elt) kind + | Int32_unsigned : (number_t, Int32.t, Bigarray.int32_elt) kind + | Float32 : (number_t, float, Bigarray.float32_elt) kind + | Float64 : (number_t, float, Bigarray.float64_elt) kind -val kind : ('a, 'b) typedArray t -> ('a, 'b) Bigarray.kind +val kind : ('typed_array, 'bigarray, 'elt) typedArray t -> ('bigarray, 'elt) Bigarray.kind val from_genarray : - ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t -> ('a, 'b) typedArray t + ('typed_array, 'bigarray, 'elt) kind + -> ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t + -> ('typed_array, 'bigarray, 'elt) typedArray t -val to_genarray : ('a, 'b) typedArray t -> ('a, 'b, Bigarray.c_layout) Bigarray.Genarray.t +val to_genarray : + ('typed_array, 'bigarray, 'elt) typedArray t + -> ('bigarray, 'elt, Bigarray.c_layout) Bigarray.Genarray.t val int8Array : (int -> int8Array t) constr @@ -139,7 +157,7 @@ val int32Array_inBuffer : (arrayBuffer t -> int -> int -> int32Array t) constr val uint32Array : (int -> uint32Array t) constr -val uint32Array_fromArray : (uint32 js_array t -> uint32Array t) constr +val uint32Array_fromArray : (number_t js_array t -> uint32Array t) constr val uint32Array_fromTypedArray : (uint32Array t -> uint32Array t) constr @@ -167,11 +185,11 @@ val float64Array_fromBuffer : (arrayBuffer t -> float64Array t) constr val float64Array_inBuffer : (arrayBuffer t -> int -> int -> float64Array t) constr -val set : ('a, 'b) typedArray t -> int -> 'a -> unit +val set : ('a, _, _) typedArray t -> int -> 'a -> unit -val get : ('a, 'b) typedArray t -> int -> 'a optdef +val get : ('a, _, _) typedArray t -> int -> 'a optdef -val unsafe_get : ('a, 'b) typedArray t -> int -> 'a +val unsafe_get : ('a, _, _) typedArray t -> int -> 'a class type dataView = object inherit arrayBufferView @@ -188,13 +206,13 @@ class type dataView = object method getUint16_ : int -> bool t -> int meth - method getInt32 : int -> int meth + method getInt32 : int -> number_t meth - method getInt32_ : int -> bool t -> int meth + method getInt32_ : int -> bool t -> number_t meth - method getUint32 : int -> uint32 meth + method getUint32 : int -> number_t meth - method getUint32_ : int -> bool t -> uint32 meth + method getUint32_ : int -> bool t -> number_t meth method getFloat32 : int -> number_t meth @@ -216,13 +234,13 @@ class type dataView = object method setUint16_ : int -> int -> bool t -> unit meth - method setInt32 : int -> int -> unit meth + method setInt32 : int -> number_t -> unit meth - method setInt32_ : int -> int -> bool t -> unit meth + method setInt32_ : int -> number_t -> bool t -> unit meth - method setUint32 : int -> uint32 -> unit meth + method setUint32 : int -> number_t -> unit meth - method setUint32_ : int -> uint32 -> bool t -> unit meth + method setUint32_ : int -> number_t -> bool t -> unit meth method setFloat32 : int -> number_t -> unit meth diff --git a/lib/tests/test_typed_array.ml b/lib/tests/test_typed_array.ml index b81df76f19..6c9a18343e 100644 --- a/lib/tests/test_typed_array.ml +++ b/lib/tests/test_typed_array.ml @@ -18,24 +18,24 @@ open Js_of_ocaml open Typed_array -open Bigarray +open! Bigarray type ('a, 'b) ba = ('a, 'b, c_layout) Genarray.t -type ('a, 'b) ta = ('a, 'b) typedArray +type ('a, 'b, 'c) ta = ('a, 'b, 'c) typedArray module Setup = struct - type (_, _) t = - | Int8 : (int, Bigarray.int8_signed_elt) t - | Uint8 : (int, Bigarray.int8_unsigned_elt) t - | Int16 : (int, Bigarray.int16_signed_elt) t - | Uint16 : (int, Bigarray.int16_unsigned_elt) t - | Int32 : (int32, Bigarray.int32_elt) t - | Float32 : (float, Bigarray.float32_elt) t - | Float64 : (float, Bigarray.float64_elt) t + type (_, _, _) t = + | Int8 : (int, int, Bigarray.int8_signed_elt) t + | Uint8 : (int, int, Bigarray.int8_unsigned_elt) t + | Int16 : (int, int, Bigarray.int16_signed_elt) t + | Uint16 : (int, int, Bigarray.int16_unsigned_elt) t + | Int32 : (Js.number_t, Int32.t, Bigarray.int32_elt) t + | Float32 : (Js.number_t, float, Bigarray.float32_elt) t + | Float64 : (Js.number_t, float, Bigarray.float64_elt) t end -let kind_of_setup : type a b. (a, b) Setup.t -> (a, b) kind = function +let kind_of_setup : type a b c. (a, b, c) Setup.t -> (b, c) kind = function | Setup.Int8 -> Int8_signed | Setup.Uint8 -> Int8_unsigned | Setup.Int16 -> Int16_signed @@ -44,7 +44,25 @@ let kind_of_setup : type a b. (a, b) Setup.t -> (a, b) kind = function | Setup.Float32 -> Float32 | Setup.Float64 -> Float64 -let ta_type_is_correct : type a b. (a, b) Setup.t -> (a, b) ta Js.t -> bool = +let convert : type a b c. (a, b, c) Setup.t -> a -> b = function + | Setup.Int8 -> Fun.id + | Setup.Uint8 -> Fun.id + | Setup.Int16 -> Fun.id + | Setup.Uint16 -> Fun.id + | Setup.Int32 -> fun f -> Int32.of_float (Js.to_float f) + | Setup.Float32 -> Js.to_float + | Setup.Float64 -> Js.to_float + +let type_of_setup : type a b c. (a, b, c) Setup.t -> (a, b, c) Typed_array.kind = function + | Setup.Int8 -> Int8_signed + | Setup.Uint8 -> Int8_unsigned + | Setup.Int16 -> Int16_signed + | Setup.Uint16 -> Int16_unsigned + | Setup.Int32 -> Int32_signed + | Setup.Float32 -> Float32 + | Setup.Float64 -> Float64 + +let ta_type_is_correct : type a b c. (a, b, c) Setup.t -> (a, b, c) ta Js.t -> bool = fun setup a -> let get_prop prop obj = Js.Unsafe.get obj (Js.string prop) in let name = a |> get_prop "constructor" |> get_prop "name" |> Js.to_string in @@ -58,7 +76,7 @@ let ta_type_is_correct : type a b. (a, b) Setup.t -> (a, b) ta Js.t -> bool = | Setup.Int32, "Int32Array" -> true | _, _ -> false -let kind_field_is_correct : type a b. (a, b) Setup.t -> (a, b) ba -> bool = +let kind_field_is_correct : type a b c. (a, b, c) Setup.t -> (b, c) ba -> bool = fun setup a -> (* To trigger a `false`, modify the `kind` integer hard coded in the * `caml_ba_kind_of_typed_array` stub @@ -73,7 +91,7 @@ let kind_field_is_correct : type a b. (a, b) Setup.t -> (a, b) ba -> bool = | Int32, Int32 -> true | _, _ -> false -let ba_of_array : type a b. (a, b) Setup.t -> a array -> (a, b) ba = +let ba_of_array : type a b c. (a, b, c) Setup.t -> b array -> (b, c) ba = fun setup a -> Array1.of_array (kind_of_setup setup) c_layout a |> genarray_of_array1 let array_of_ba : type a b. (a, b) ba -> a array = @@ -85,16 +103,19 @@ let array_of_ba : type a b. (a, b) ba -> a array = in aux 0 |> Array.of_list -let array_of_ta : type a b. (a, b) Setup.t -> (a, b) ta Js.t -> a array = - fun _ a -> +let array_of_ta : type a b c. (a, b, c) Setup.t -> (a, b, c) ta Js.t -> b array = + fun setup a -> let len = a##.length in - let rec aux i = if i == len then [] else unsafe_get a i :: aux (i + 1) in + let rec aux i = + if i == len then [] else convert setup (unsafe_get a i) :: aux (i + 1) + in aux 0 |> Array.of_list -let test setup a0 = +let test : type a b c. (a, b, c) Setup.t -> b array -> unit = + fun setup a0 -> let a1 = ba_of_array setup a0 in - let a2 = from_genarray a1 in + let a2 = from_genarray (type_of_setup setup) a1 in if not (array_of_ta setup a2 = a0) then print_endline "`a2` doesnt match `a0`"; if not (ta_type_is_correct setup a2) then print_endline "corrupted typedArray type"; @@ -103,6 +124,21 @@ let test setup a0 = if not (kind_field_is_correct setup a3) then print_endline "corrupted `kind`"; () +(* Byte-wise equality *) +let typed_arrays_equal ta1 ta2 = + let byte_len1 = ta1##.byteLength and byte_len2 = ta2##.byteLength in + if not (Int.equal byte_len1 byte_len2) + then false + else + let view1 = new%js dataView ta1##.buffer in + let view2 = new%js dataView ta2##.buffer in + let rec cmp i = + if i >= byte_len1 + then true + else Int.equal (view1##getUint8 i) (view2##getUint8 i) && cmp (i + 1) + in + cmp 0 + let%expect_test "float32" = test Setup.Float32 [| Float.neg_infinity; -1.; 0.; 1.; Float.infinity |]; [%expect {||}] @@ -116,7 +152,17 @@ let%expect_test "int8" = [%expect {||}] let%expect_test "uint8" = - test Setup.Uint8 [| 0; 255 |]; + let a = [| 0; 255 |] in + test Setup.Uint8 a; + let ta = from_genarray (type_of_setup Setup.Uint8) (ba_of_array Setup.Uint8 a) in + let bytes = Typed_array.Bytes.of_uint8Array ta in + let ta' = Typed_array.Bytes.to_uint8Array bytes in + if not (typed_arrays_equal ta ta') + then print_endline "round-trip from uint8Array to bytes and back not equal"; + let buffer = ta##.buffer in + let bytes'' = Typed_array.Bytes.of_arrayBuffer buffer in + if not (Stdlib.Bytes.equal bytes'' bytes) + then print_endline "bytes from arrayBuffer not equal to bytes from of_uint8Array"; [%expect {||}] let%expect_test "int16" =