Bigarray support

jscomp/core/lam_analysis.ml

@@ -155,7 +155,7 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | Pasrint64
       | Pint64comp _
       (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
-
+      | Pbigarrayref _ (* TODO it may raise an exception....*)
       (* Compile time constants *)
       | Pctconst _
       (* Integer to external pointer *)
@@ -182,6 +182,9 @@ let rec no_side_effects (lam : Lam.t) : bool =
       | Pbytessetu
       | Pbytessets
       (* Operations on boxed integers (Nativeint.t, Int32.t, Int64.t) *)
+      | Pbigarrayset _
+      (* size of the nth dimension of a big array *)
+      | Pbigarraydim _ 
       | Parraysets
       (* byte swap *)
       | Parraysetu

jscomp/core/lam_compat.ml

@@ -175,4 +175,34 @@ type set_field_dbg_info = Lambda.set_field_dbg_info =
   | Fld_record_extension_set of string
 
 
-
+type bigarray_kind = Lambda.bigarray_kind = 
+    Pbigarray_unknown
+  | Pbigarray_float32 | Pbigarray_float64
+  | Pbigarray_sint8 | Pbigarray_uint8
+  | Pbigarray_sint16 | Pbigarray_uint16
+  | Pbigarray_int32 | Pbigarray_int64
+  | Pbigarray_caml_int | Pbigarray_native_int
+  | Pbigarray_complex32 | Pbigarray_complex64
+
+
+(* let eq_bigarray_kind (p : bigarray_kind) (p1 : bigarray_kind) = 
+  match p with   
+  | Pbigarray_unknown -> p1 = Pbigarray_unknown
+  | Pbigarray_float32 -> p1 = Pbigarray_float32
+  | Pbigarray_float64 -> p1 =  Pbigarray_float64
+  | Pbigarray_sint8 -> p1 = Pbigarray_sint8
+  | Pbigarray_uint8 -> p1 = Pbigarray_uint8
+  | Pbigarray_sint16 -> p1 = Pbigarray_sint16 
+  | Pbigarray_uint16 -> p1 = Pbigarray_uint16
+  | Pbigarray_int32  -> p1 = Pbigarray_int32
+  | Pbigarray_int64 -> p1 = Pbigarray_int64
+  | Pbigarray_caml_int -> p1 = Pbigarray_caml_int
+  | Pbigarray_native_int -> p1 = Pbigarray_native_int
+  | Pbigarray_complex32  -> p1 = Pbigarray_complex32
+  | Pbigarray_complex64 -> p1 = Pbigarray_complex64 *)
+
+
+type bigarray_layout = Lambda.bigarray_layout = 
+    Pbigarray_unknown_layout
+  | Pbigarray_c_layout
+  | Pbigarray_fortran_layout

jscomp/core/lam_compat.mli

@@ -81,6 +81,20 @@ type set_field_dbg_info = Lambda.set_field_dbg_info =
   | Fld_record_inline_set of string
   | Fld_record_extension_set of string
 
+type bigarray_kind = Lambda.bigarray_kind = 
+    Pbigarray_unknown
+  | Pbigarray_float32 | Pbigarray_float64
+  | Pbigarray_sint8 | Pbigarray_uint8
+  | Pbigarray_sint16 | Pbigarray_uint16
+  | Pbigarray_int32 | Pbigarray_int64
+  | Pbigarray_caml_int | Pbigarray_native_int
+  | Pbigarray_complex32 | Pbigarray_complex64
+
+
+type bigarray_layout = Lambda.bigarray_layout = 
+    Pbigarray_unknown_layout
+  | Pbigarray_c_layout
+  | Pbigarray_fortran_layout
 
 val cmp_int32 : integer_comparison -> int32 -> int32 -> bool
 val cmp_int64 : integer_comparison -> int64 -> int64 -> bool

jscomp/core/lam_compile_primitive.ml

@@ -509,7 +509,58 @@ let translate  loc
      )
   | Pduprecord (Record_regular| Record_extension| Record_inlined _ ) ->
       Lam_dispatch_primitive.translate loc "caml_obj_dup" args
+  | Pbigarrayref (unsafe, dimension, kind, layout)
+    -> 
+    (* can be refined to 
+        [caml_bigarray_float32_c_get_1]
+        note that kind can be [generic]
+        and layout can be [unknown],
+        dimension is always available
+    *)
+    begin match dimension, kind, layout, unsafe with 
+      | 1,  ( Pbigarray_float32 | Pbigarray_float64
+            | Pbigarray_sint8 | Pbigarray_uint8
+            | Pbigarray_sint16 | Pbigarray_uint16
+            | Pbigarray_int32 | Pbigarray_int64
+            | Pbigarray_caml_int | Pbigarray_native_int
+            | Pbigarray_complex32 | Pbigarray_complex64), Pbigarray_c_layout, _
+        -> 
+        begin match args with
+          | [_x;_indx] -> E.runtime_call Js_runtime_modules.bigarray
+              ("caml_ba_get_" ^ string_of_int dimension ) args
+          | _ -> assert false
+        end
+      | _, _, _ ,_ -> 
+        E.runtime_call Js_runtime_modules.bigarray
+          ("caml_ba_get_" ^ string_of_int dimension ) args
+    end
+  | Pbigarrayset (unsafe, dimension, kind, layout)
+    -> 
+    begin match dimension, kind, layout, unsafe with 
+      | 1,  ( Pbigarray_float32 | Pbigarray_float64
+            | Pbigarray_sint8 | Pbigarray_uint8
+            | Pbigarray_sint16 | Pbigarray_uint16
+            | Pbigarray_int32 | Pbigarray_int64
+            | Pbigarray_caml_int | Pbigarray_native_int
+            | Pbigarray_complex32 | Pbigarray_complex64), Pbigarray_c_layout, _
+        -> 
+        begin match args with 
+          | [_x; _index; _value] -> 
+            E.runtime_call Js_runtime_modules.bigarray 
+              ("caml_ba_set_" ^ string_of_int dimension) args          
+          | _ -> assert false
+        end
+
+      | _ , _, _,_ 
+        -> 
+          E.runtime_call Js_runtime_modules.bigarray 
+            ("caml_ba_set_" ^ string_of_int dimension) args
+    end
 
+  | Pbigarraydim i
+    -> 
+      E.runtime_call Js_runtime_modules.bigarray 
+        ("caml_ba_dim_" ^ string_of_int i) args     
   | Plazyforce
     (* FIXME: we don't inline lazy force or at least
       let buckle handle it

jscomp/core/lam_convert.ml

@@ -477,7 +477,9 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
     | Pint32 -> prim ~primitive:(Pasrint) ~args loc
     | Pint64 -> prim ~primitive:(Pasrint64) ~args loc
     end
-  | Pbigarraydim _
+  | Pbigarraydim x -> prim ~primitive:(Pbigarraydim x) ~args loc
+  | Pbigarrayref (unsafe, dimension, kind, layout) -> prim ~primitive:(Pbigarrayref (unsafe, dimension, kind, layout)) ~args loc
+  | Pbigarrayset (unsafe, dimension, kind, layout) -> prim ~primitive:(Pbigarrayset (unsafe, dimension, kind, layout)) ~args loc
   | Pbigstring_load_16 _
   | Pbigstring_load_32 _
   | Pbigstring_load_64 _
@@ -492,9 +494,7 @@ let lam_prim ~primitive:( p : Lambda.primitive) ~args loc : Lam.t =
   | Pbytes_set_64 _
   | Pstring_load_16 _
   | Pstring_load_32 _
-  | Pstring_load_64 _
-  | Pbigarrayref _
-  | Pbigarrayset _ ->
+  | Pstring_load_64 _ ->
     Location.raise_errorf ~loc "unsupported primitive"
   | Pctconst x ->
     begin match x with

jscomp/core/lam_dispatch_primitive.ml

@@ -607,7 +607,34 @@ let translate loc (prim_name : string)
           E.unchecked_int32_mul e1 e2
         | _ -> assert false
       end
-
+    | "caml_ba_create" -> call Js_runtime_modules.bigarray
+    | "caml_ba_get_generic" -> call Js_runtime_modules.bigarray
+    | "caml_ba_set_generic" -> call Js_runtime_modules.bigarray
+    | "caml_ba_num_dims" -> call Js_runtime_modules.bigarray
+    | "caml_ba_dim" -> call Js_runtime_modules.bigarray
+    | "caml_ba_kind" -> call Js_runtime_modules.bigarray
+    | "caml_ba_layout" -> call Js_runtime_modules.bigarray
+    | "caml_ba_change_layout" -> call Js_runtime_modules.bigarray
+    | "caml_ba_blit" -> call Js_runtime_modules.bigarray
+    | "caml_ba_fill" -> call Js_runtime_modules.bigarray
+    | "caml_ba_get_1" -> call Js_runtime_modules.bigarray
+    | "caml_ba_set_1" -> call Js_runtime_modules.bigarray
+    | "caml_ba_unsafe_get_1" -> call Js_runtime_modules.bigarray
+    | "caml_ba_unsafe_set_1" -> call Js_runtime_modules.bigarray
+    | "caml_ba_dim_1" -> call Js_runtime_modules.bigarray
+    | "caml_ba_sub" -> call Js_runtime_modules.bigarray
+    | "caml_ba_get_2" -> call Js_runtime_modules.bigarray
+    | "caml_ba_set_2" -> call Js_runtime_modules.bigarray
+    | "caml_ba_unsafe_get_2" -> call Js_runtime_modules.bigarray
+    | "caml_ba_unsafe_set_2" -> call Js_runtime_modules.bigarray
+    | "caml_ba_dim_2" -> call Js_runtime_modules.bigarray
+    | "caml_ba_get_3" -> call Js_runtime_modules.bigarray
+    | "caml_ba_set_3" -> call Js_runtime_modules.bigarray
+    | "caml_ba_unsafe_get_3" -> call Js_runtime_modules.bigarray
+    | "caml_ba_unsafe_set_3" -> call Js_runtime_modules.bigarray
+    | "caml_ba_dim_3" -> call Js_runtime_modules.bigarray
+    | "caml_ba_slice" -> call Js_runtime_modules.bigarray
+    | "caml_ba_reshape" -> call Js_runtime_modules.bigarray
     | _ ->
       Bs_warnings.warn_missing_primitive loc prim_name  ;
       E.resolve_and_apply prim_name args

jscomp/core/lam_primitive.ml

@@ -149,6 +149,10 @@ type t =
 
   | Pfield_computed (* Mostly used in object compilation *)
   | Psetfield_computed
+  | Pbigarrayref of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
+  | Pbigarrayset of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
+  (* size of the nth dimension of a big array *)
+  | Pbigarraydim of int
 
 
 
@@ -285,8 +289,11 @@ let eq_primitive_approx ( lhs : t) (rhs : t) =
   | Pvoid_run  -> rhs = Pvoid_run
   | Pfull_apply -> rhs = Pfull_apply
   | Pjs_fn_method  -> rhs = Pjs_fn_method
+  | Pbigarrayref  _ 
+  | Pbigarrayset _ 
   | Praw_js_code _
    -> false (* TOO lazy, here comparison is only approximation*)
 
   | Pfield_computed -> rhs = Pfield_computed
   | Psetfield_computed -> rhs = Psetfield_computed
+  | Pbigarraydim dim -> (match rhs with Pbigarraydim dim1 -> dim = dim1 | _ -> false )

jscomp/core/lam_primitive.mli

@@ -144,5 +144,10 @@ type t =
 
   | Pfield_computed (* Mostly used in object compilation *)
   | Psetfield_computed
+  (* Operations on big arrays: (unsafe, #dimensions, kind, layout) *)
+  | Pbigarrayref of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
+  | Pbigarrayset of bool * int * Lam_compat.bigarray_kind * Lam_compat.bigarray_layout
+  (* size of the nth dimension of a big array *)
+  | Pbigarraydim of int
 
 val eq_primitive_approx : t -> t -> bool

jscomp/core/lam_print.ml

@@ -48,6 +48,28 @@ let rec struct_const ppf (cst : Lam_constant.t) =
     fprintf ppf "@[<1>[|@[%s%a@]|]@]" f1 floats fl
 
 
+let print_bigarray name unsafe (kind : Lam_compat.bigarray_kind) ppf 
+    (layout : Lam_compat.bigarray_layout) =
+  fprintf ppf "Bigarray.%s[%s,%s]"
+    (if unsafe then "unsafe_"^ name else name)
+    (match kind with
+     | Lam_compat.Pbigarray_unknown -> "generic"
+     | Pbigarray_float32 -> "float32"
+     | Pbigarray_float64 -> "float64"
+     | Pbigarray_sint8 -> "sint8"
+     | Pbigarray_uint8 -> "uint8"
+     | Pbigarray_sint16 -> "sint16"
+     | Pbigarray_uint16 -> "uint16"
+     | Pbigarray_int32 -> "int32"
+     | Pbigarray_int64 -> "int64"
+     | Pbigarray_caml_int -> "camlint"
+     | Pbigarray_native_int -> "nativeint"
+     | Pbigarray_complex32 -> "complex32"
+     | Pbigarray_complex64 -> "complex64")
+    (match layout with
+     | Lam_compat.Pbigarray_unknown_layout -> "unknown"
+     | Pbigarray_c_layout -> "C"
+     | Pbigarray_fortran_layout -> "Fortran")
 
 let record_rep ppf (r : Lam_primitive.record_representation) =
   match r with
@@ -224,7 +246,11 @@ let primitive ppf (prim : Lam_primitive.t) = match prim with
   | Pint64comp(Cgt) -> fprintf ppf ">"
   | Pint64comp(Cle) -> fprintf ppf "<="
   | Pint64comp(Cge) -> fprintf ppf ">="
-
+  | Pbigarrayref(unsafe, _n, kind, layout) ->
+    print_bigarray "get" unsafe kind ppf layout
+  | Pbigarrayset(unsafe, _n, kind, layout) ->
+    print_bigarray "set" unsafe kind ppf layout
+  | Pbigarraydim(n) -> fprintf ppf "Bigarray.dim_%i" n
 
 
 type print_kind =

jscomp/ext/js_runtime_modules.ml

@@ -43,7 +43,7 @@ let caml_primitive = "Caml"
 let int64 = "Caml_int64"
 let md5 = "Caml_md5"
 let int32 = "Caml_int32"
-
+let bigarray = "Caml_bigarray"
 
 let option = "Caml_option"
 let module_ = "Caml_module"