Merge flambda-backend changes

asmcomp/cmmgen.ml

@@ -690,7 +690,7 @@ and transl_catch env nfail ids body handler dbg =
          let strict =
            match kind with
            | Pfloatval | Pboxedintval _ -> false
-           | Pintval | Pgenval | Pblock _ -> true
+           | Pintval | Pgenval | Pblock _ | Parrayval _ -> true
          in
          u := join_unboxed_number_kind ~strict !u
              (is_unboxed_number_cmm ~strict c)
@@ -1145,7 +1145,7 @@ and transl_let env str kind id exp body =
            we do it only if this indeed allows us to get rid of
            some allocations in the bound expression. *)
         is_unboxed_number_cmm ~strict:false cexp
-    | _, (Pgenval | Pblock _) ->
+    | _, (Pgenval | Pblock _ | Parrayval _) ->
         (* Here we don't know statically that the bound expression
            evaluates to an unboxable number type.  We need to be stricter
            and ensure that all possible branches in the expression

lambda/lambda.ml

@@ -162,6 +162,7 @@ and float_comparison =
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
   | Pblock of { tag : int; fields : value_kind list }
+  | Parrayval of array_kind
 
 and block_shape =
   value_kind list option
@@ -212,11 +213,13 @@ let rec equal_value_kind x y =
   | Pfloatval, Pfloatval -> true
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
   | Pintval, Pintval -> true
+  | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2
   | Pblock { tag = tag1; fields = fields1 },
     Pblock { tag = tag2; fields = fields2 } ->
     tag1 = tag2 && List.length fields1 = List.length fields2 &&
     List.for_all2 equal_value_kind fields1 fields2
-  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pblock _), _ -> false
+  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pblock _
+      | Parrayval _), _ -> false
 
 
 type structured_constant =

lambda/lambda.mli

@@ -175,6 +175,7 @@ and array_kind =
 and value_kind =
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
   | Pblock of { tag : int; fields : value_kind list }
+  | Parrayval of array_kind
 
 and block_shape =
   value_kind list option

lambda/printlambda.ml

@@ -63,6 +63,7 @@ let rec value_kind ppf = function
   | Pgenval -> ()
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
+  | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
   | Pblock { tag; fields } ->
     fprintf ppf "[%d: %a]" tag
@@ -73,6 +74,7 @@ and value_kind' ppf = function
   | Pgenval -> fprintf ppf "*"
   | Pintval -> fprintf ppf "[int]"
   | Pfloatval -> fprintf ppf "[float]"
+  | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
   | Pblock { tag; fields } ->
     fprintf ppf "[%d: %a]" tag
@@ -83,6 +85,7 @@ let return_kind ppf = function
   | Pgenval -> ()
   | Pintval -> fprintf ppf ": int@ "
   | Pfloatval -> fprintf ppf ": float@ "
+  | Parrayval elt_kind -> fprintf ppf ": %sarray@ " (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf ": %s@ " (boxed_integer_name bi)
   | Pblock { tag; fields } ->
     fprintf ppf ": [%d: %a]@ " tag
@@ -93,6 +96,7 @@ let field_kind ppf = function
   | Pgenval -> pp_print_string ppf "*"
   | Pintval -> pp_print_string ppf "int"
   | Pfloatval -> pp_print_string ppf "float"
+  | Parrayval elt_kind -> fprintf ppf "%s-array" (array_kind elt_kind)
   | Pboxedintval bi -> pp_print_string ppf (boxed_integer_name bi)
   | Pblock { tag; fields } ->
     fprintf ppf "[%d: %a]" tag

middle_end/clambda_primitives.ml

@@ -132,6 +132,7 @@ and value_kind = Lambda.value_kind =
   (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
   | Pblock of { tag : int; fields : value_kind list }
+  | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =

middle_end/clambda_primitives.mli

@@ -135,6 +135,7 @@ and value_kind = Lambda.value_kind =
   (* CR mshinwell: Pfloatval should be renamed to Pboxedfloatval *)
     Pgenval | Pfloatval | Pboxedintval of boxed_integer | Pintval
   | Pblock of { tag : int; fields : value_kind list }
+  | Parrayval of array_kind
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =

middle_end/printclambda.ml

@@ -30,6 +30,10 @@ let value_kind =
   | Pgenval -> ""
   | Pintval -> ":int"
   | Pfloatval -> ":float"
+  | Parrayval Pgenarray -> ":genarray"
+  | Parrayval Pintarray -> ":intarray"
+  | Parrayval Pfloatarray -> ":floatarray"
+  | Parrayval Paddrarray -> ":addrarray"
   | Pboxedintval Pnativeint -> ":nativeint"
   | Pboxedintval Pint32 -> ":int32"
   | Pboxedintval Pint64 -> ":int64"

parsing/extensions.ml

@@ -104,7 +104,7 @@ let unwrap_structure ~loc = function
 let unmap_comprehension ~loc payload =
   let str = unwrap_structure ~loc payload in
   let get_hd_and_tl = function
-    | [] -> Misc.fatal_error "Unexpected sturcture in comprehension extension."
+    | [] -> Misc.fatal_error "Unexpected structure in comprehension extension."
     | hd::tl -> hd, tl
   in
   let str_hd, str_tl = get_hd_and_tl str in
@@ -161,7 +161,7 @@ let extension_expr_of_payload ~loc ((name, payload) : extension) =
 
 let report_error ~loc = function
   | Extension_not_existent extension_name ->
-    Location.errorf ~loc "Extension %s does not exsist." extension_name
+    Location.errorf ~loc "Extension %s does not exist." extension_name
   | Illegal_comprehension_extension_construct ->
     Location.errorf ~loc "Wrong extension syntax for comprehensions."
 

testsuite/tests/translprim/array_spec.compilers.flat.reference

@@ -1,21 +1,23 @@
 (setglobal Array_spec!
   (let
-    (int_a = (makearray[int] 1 2 3)
-     float_a = (makearray[float] 1. 2. 3.)
-     addr_a = (makearray[addr] "a" "b" "c"))
+    (int_a =[intarray] (makearray[int] 1 2 3)
+     float_a =[floatarray] (makearray[float] 1. 2. 3.)
+     addr_a =[addrarray] (makearray[addr] "a" "b" "c"))
     (seq (array.length[int] int_a) (array.length[float] float_a)
-      (array.length[addr] addr_a) (function a : int (array.length[gen] a))
+      (array.length[addr] addr_a)
+      (function a[genarray] : int (array.length[gen] a))
       (array.get[int] int_a 0) (array.get[float] float_a 0)
-      (array.get[addr] addr_a 0) (function a (array.get[gen] a 0))
+      (array.get[addr] addr_a 0) (function a[genarray] (array.get[gen] a 0))
       (array.unsafe_get[int] int_a 0) (array.unsafe_get[float] float_a 0)
       (array.unsafe_get[addr] addr_a 0)
-      (function a (array.unsafe_get[gen] a 0)) (array.set[int] int_a 0 1)
-      (array.set[float] float_a 0 1.) (array.set[addr] addr_a 0 "a")
-      (function a x : int (array.set[gen] a 0 x))
+      (function a[genarray] (array.unsafe_get[gen] a 0))
+      (array.set[int] int_a 0 1) (array.set[float] float_a 0 1.)
+      (array.set[addr] addr_a 0 "a")
+      (function a[genarray] x : int (array.set[gen] a 0 x))
       (array.unsafe_set[int] int_a 0 1)
       (array.unsafe_set[float] float_a 0 1.)
       (array.unsafe_set[addr] addr_a 0 "a")
-      (function a x : int (array.unsafe_set[gen] a 0 x))
+      (function a[genarray] x : int (array.unsafe_set[gen] a 0 x))
       (let
         (eta_gen_len = (function prim stub (array.length[gen] prim))
          eta_gen_safe_get =

typing/typeopt.ml

@@ -169,6 +169,10 @@ let value_kind env ty =
       Pboxedintval Pint64
     | Tconstr(p, _, _) when Path.same p Predef.path_nativeint ->
       Pboxedintval Pnativeint
+    | Tconstr(p, _, _)
+        when (Path.same p Predef.path_array
+              || Path.same p Predef.path_floatarray) ->
+      Parrayval (array_type_kind env ty)
     | Tconstr(p, _, _) ->
       if Numbers.Int.Set.mem ty.id visited || fuel <= 0 then
         Pgenval