flambda-backend: Add Vec128 sort (ocaml-flambda#2965)

bytecomp/bytegen.ml

@@ -145,6 +145,7 @@ let preserve_tailcall_for_prim = function
   | Pobj_magic _
   | Prunstack | Pperform | Presume | Preperform
   | Pbox_float (_, _) | Punbox_float _
+  | Pbox_vector (_, _) | Punbox_vector _
   | Pbox_int _ | Punbox_int _ ->
       true
   | Pbytes_to_string | Pbytes_of_string
@@ -634,8 +635,9 @@ let comp_primitive stack_info p sz args =
   | Pfloatarray_set_128 _ | Pfloat_array_set_128 _ | Pint_array_set_128 _
   | Punboxed_float_array_set_128 _ | Punboxed_float32_array_set_128 _
   | Punboxed_int32_array_set_128 _ | Punboxed_int64_array_set_128 _
-  | Punboxed_nativeint_array_set_128 _ ->
-    fatal_error "128-bit load/store is not supported in bytecode mode."
+  | Punboxed_nativeint_array_set_128 _
+  | Pbox_vector _ | Punbox_vector _ ->
+    fatal_error "SIMD is not supported in bytecode mode."
   | Preinterpret_tagged_int63_as_unboxed_int64 ->
     if not (Target_system.is_64_bit ())
     then

lambda/lambda.ml

@@ -311,6 +311,8 @@ type primitive =
   | Pbox_float of boxed_float * locality_mode
   | Punbox_int of boxed_integer
   | Pbox_int of boxed_integer * locality_mode
+  | Punbox_vector of boxed_vector
+  | Pbox_vector of boxed_vector * locality_mode
   | Preinterpret_unboxed_int64_as_tagged_int63
   | Preinterpret_tagged_int63_as_unboxed_int64
   (* Jane Street extensions *)
@@ -424,21 +426,14 @@ and boxed_float = Primitive.boxed_float =
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
+and boxed_vector = Primitive.boxed_vector =
+  | Pvec128
+
 and unboxed_float = boxed_float
 
 and unboxed_integer = boxed_integer
 
-and vec128_type =
-  | Unknown128
-  | Int8x16
-  | Int16x8
-  | Int32x4
-  | Int64x2
-  | Float32x4
-  | Float64x2
-
-and boxed_vector =
-  | Pvec128 of vec128_type
+and unboxed_vector = boxed_vector
 
 and bigarray_kind =
     Pbigarray_unknown
@@ -461,52 +456,24 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
-let vec128_name = function
-  | Unknown128 -> "unknown128"
-  | Int8x16 -> "int8x16"
-  | Int16x8 -> "int16x8"
-  | Int32x4 -> "int32x4"
-  | Int64x2 -> "int64x2"
-  | Float32x4 -> "float32x4"
-  | Float64x2 -> "float64x2"
-
 let equal_boxed_integer = Primitive.equal_boxed_integer
 
 let equal_boxed_float = Primitive.equal_boxed_float
 
-let equal_boxed_vector_size v1 v2 =
-  match v1, v2 with
-  | Pvec128 _, Pvec128 _ -> true
+let equal_boxed_vector = Primitive.equal_boxed_vector
 
 let compare_boxed_vector = Stdlib.compare
 
 let print_boxed_vector ppf t =
   match t with
-  | Pvec128 v -> Format.pp_print_string ppf (vec128_name v)
-
-let join_vec128_types v1 v2 =
-  match v1, v2 with
-  | Unknown128, _ | _, Unknown128 -> Unknown128
-  | Int8x16, Int8x16 -> Int8x16
-  | Int16x8, Int16x8 -> Int16x8
-  | Int32x4, Int32x4 -> Int32x4
-  | Int64x2, Int64x2 -> Int64x2
-  | Float32x4, Float32x4 -> Float32x4
-  | Float64x2, Float64x2 -> Float64x2
-  | (Int8x16 | Int16x8 | Int32x4 | Int64x2 | Float32x4 | Float64x2), _ ->
-    Unknown128
-
-let join_boxed_vector_layout v1 v2 =
-  match v1, v2 with
-  | Pvec128 v1, Pvec128 v2 -> Punboxed_vector (Pvec128 (join_vec128_types v1 v2))
+  | Pvec128 -> Format.pp_print_string ppf "Vec128"
 
 let rec equal_value_kind x y =
   match x, y with
   | Pgenval, Pgenval -> true
   | Pboxedfloatval f1, Pboxedfloatval f2 -> equal_boxed_float f1 f2
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
-  | Pboxedvectorval bi1, Pboxedvectorval bi2 ->
-    equal_boxed_vector_size bi1 bi2
+  | Pboxedvectorval bv1, Pboxedvectorval bv2 -> equal_boxed_vector bv1 bv2
   | Pintval, Pintval -> true
   | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2
   | Pvariant { consts = consts1; non_consts = non_consts1; },
@@ -550,9 +517,8 @@ let rec compatible_layout x y =
   | _, Pbottom -> true
   | Pvalue _, Pvalue _ -> true
   | Punboxed_float f1, Punboxed_float f2 -> equal_boxed_float f1 f2
-  | Punboxed_int bi1, Punboxed_int bi2 ->
-      equal_boxed_integer bi1 bi2
-  | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector_size bi1 bi2
+  | Punboxed_int bi1, Punboxed_int bi2 -> equal_boxed_integer bi1 bi2
+  | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector bi1 bi2
   | Punboxed_product layouts1, Punboxed_product layouts2 ->
       List.compare_lengths layouts1 layouts2 = 0
       && List.for_all2 compatible_layout layouts1 layouts2
@@ -890,22 +856,11 @@ let layout_string = Pvalue Pgenval
 let layout_unboxed_int ubi = Punboxed_int ubi
 let layout_boxedint bi = Pvalue (Pboxedintval bi)
 
-let layout_unboxed_vector (v : Primitive.boxed_vector) =
-  match v with
-  | Pvec128 Int8x16 -> Punboxed_vector (Pvec128 Int8x16)
-  | Pvec128 Int16x8 -> Punboxed_vector (Pvec128 Int16x8)
-  | Pvec128 Int32x4 -> Punboxed_vector (Pvec128 Int32x4)
-  | Pvec128 Int64x2 -> Punboxed_vector (Pvec128 Int64x2)
-  | Pvec128 Float32x4 -> Punboxed_vector (Pvec128 Float32x4)
-  | Pvec128 Float64x2 -> Punboxed_vector (Pvec128 Float64x2)
-
-let layout_boxed_vector : Primitive.boxed_vector -> layout = function
-  | Pvec128 Int8x16 -> Pvalue (Pboxedvectorval (Pvec128 Int8x16))
-  | Pvec128 Int16x8 -> Pvalue (Pboxedvectorval (Pvec128 Int16x8))
-  | Pvec128 Int32x4 -> Pvalue (Pboxedvectorval (Pvec128 Int32x4))
-  | Pvec128 Int64x2 -> Pvalue (Pboxedvectorval (Pvec128 Int64x2))
-  | Pvec128 Float32x4 -> Pvalue (Pboxedvectorval (Pvec128 Float32x4))
-  | Pvec128 Float64x2 -> Pvalue (Pboxedvectorval (Pvec128 Float64x2))
+let layout_unboxed_vector = function
+  | Pvec128 -> Punboxed_vector Pvec128
+
+let layout_boxed_vector = function
+  | Pvec128 -> Pvalue (Pboxedvectorval Pvec128)
 
 let layout_lazy = Pvalue Pgenval
 let layout_lazy_contents = Pvalue Pgenval
@@ -1818,8 +1773,8 @@ let primitive_may_allocate : primitive -> locality_mode option = function
   | Pprobe_is_enabled _ -> None
   | Pobj_dup -> Some alloc_heap
   | Pobj_magic _ -> None
-  | Punbox_float _ | Punbox_int _ -> None
-  | Pbox_float (_, m) | Pbox_int (_, m) -> Some m
+  | Punbox_float _ | Punbox_int _ | Punbox_vector _ -> None
+  | Pbox_float (_, m) | Pbox_int (_, m) | Pbox_vector (_, m) -> Some m
   | Prunstack | Presume | Pperform | Preperform
     (* CR mshinwell: check *)
   | Ppoll ->
@@ -1866,6 +1821,7 @@ let rec layout_of_const_sort (c : Jkind.Sort.Const.t) : layout =
   | Base Word -> layout_unboxed_nativeint
   | Base Bits32 -> layout_unboxed_int32
   | Base Bits64 -> layout_unboxed_int64
+  | Base Vec128 -> layout_unboxed_vector Pvec128
   | Base Void -> assert false
   | Product sorts ->
     layout_unboxed_product (List.map layout_of_const_sort sorts)
@@ -1932,6 +1888,8 @@ let primitive_result_layout (p : primitive) =
   | Pbox_float (f, _) -> layout_boxed_float f
   | Pufloatfield _ -> Punboxed_float Pfloat64
   | Punbox_float float_kind -> Punboxed_float float_kind
+  | Pbox_vector (v, _) -> layout_boxed_vector v
+  | Punbox_vector v -> Punboxed_vector v
   | Pmixedfield (_, kind, _, _) -> layout_of_mixed_field kind
   | Pccall { prim_native_repr_res = _, repr_res } -> layout_of_extern_repr repr_res
   | Praise _ -> layout_bottom
@@ -1972,7 +1930,7 @@ let primitive_result_layout (p : primitive) =
       layout_boxedint Pint64
   | Pstring_load_128 _ | Pbytes_load_128 _
   | Pbigstring_load_128 { boxed = true; _ } ->
-      layout_boxed_vector (Pvec128 Int8x16)
+      layout_boxed_vector Pvec128
   | Pbigstring_load_32 { boxed = false; _ }
   | Pstring_load_32 { boxed = false; _ }
   | Pbytes_load_32 { boxed = false; _ } -> layout_unboxed_int Pint32
@@ -1982,20 +1940,17 @@ let primitive_result_layout (p : primitive) =
   | Pbigstring_load_64 { boxed = false; _ }
   | Pstring_load_64 { boxed = false; _ }
   | Pbytes_load_64 { boxed = false; _ } -> layout_unboxed_int Pint64
-  | Pbigstring_load_128 { boxed = false; _ } ->
-      layout_unboxed_vector (Pvec128 Int8x16)
+  | Pbigstring_load_128 { boxed = false; _ } -> layout_unboxed_vector Pvec128
   | Pfloatarray_load_128 _ | Pfloat_array_load_128 _
-  | Punboxed_float_array_load_128 _ ->
-    layout_boxed_vector (Pvec128 Float64x2)
-  | Punboxed_float32_array_load_128 _ ->
-    layout_boxed_vector (Pvec128 Float32x4)
+  | Punboxed_float_array_load_128 _ -> layout_boxed_vector Pvec128
+  | Punboxed_float32_array_load_128 _ -> layout_boxed_vector Pvec128
   | Pint_array_load_128 _ | Punboxed_int64_array_load_128 _
   | Punboxed_nativeint_array_load_128 _ ->
     (* 128-bit types are only supported in the x86_64 backend, so we may
        assume that nativeint is 64 bits. *)
-    layout_boxed_vector (Pvec128 Int64x2)
+    layout_boxed_vector Pvec128
   | Punboxed_int32_array_load_128 _ ->
-    layout_boxed_vector (Pvec128 Int32x4)
+    layout_boxed_vector Pvec128
   | Pbigarrayref (_, _, kind, _) ->
       begin match kind with
       | Pbigarray_unknown -> layout_any_value

lambda/lambda.mli

@@ -303,6 +303,8 @@ type primitive =
   | Pbox_float of boxed_float * locality_mode
   | Punbox_int of boxed_integer
   | Pbox_int of boxed_integer * locality_mode
+  | Punbox_vector of boxed_vector
+  | Pbox_vector of boxed_vector * locality_mode
   | Preinterpret_unboxed_int64_as_tagged_int63
   | Preinterpret_tagged_int63_as_unboxed_int64
     (** At present [Preinterpret_unboxed_int64_as_tagged_int63] and
@@ -445,21 +447,14 @@ and boxed_float = Primitive.boxed_float =
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
+and boxed_vector = Primitive.boxed_vector =
+  | Pvec128
+
 and unboxed_float = boxed_float
 
 and unboxed_integer = boxed_integer
 
-and vec128_type =
-  | Unknown128
-  | Int8x16
-  | Int16x8
-  | Int32x4
-  | Int64x2
-  | Float32x4
-  | Float64x2
-
-and boxed_vector =
-  | Pvec128 of vec128_type
+and unboxed_vector = boxed_vector
 
 and bigarray_kind =
     Pbigarray_unknown
@@ -482,10 +477,6 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
-val vec128_name: vec128_type -> string
-
-val join_boxed_vector_layout: boxed_vector -> boxed_vector -> layout
-
 val equal_value_kind : value_kind -> value_kind -> bool
 
 val equal_layout : layout -> layout -> bool
@@ -496,7 +487,7 @@ val equal_boxed_float : boxed_float -> boxed_float -> bool
 
 val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
 
-val equal_boxed_vector_size : boxed_vector -> boxed_vector -> bool
+val equal_boxed_vector : boxed_vector -> boxed_vector -> bool
 
 val compare_boxed_vector : boxed_vector -> boxed_vector -> int
 
@@ -807,7 +798,7 @@ val layout_string : layout
 val layout_boxed_float : boxed_float -> layout
 val layout_unboxed_float : boxed_float -> layout
 val layout_boxedint : boxed_integer -> layout
-val layout_boxed_vector : Primitive.boxed_vector -> layout
+val layout_boxed_vector : boxed_vector -> layout
 (* A layout that is Pgenval because it is the field of a tuple *)
 val layout_tuple_element : layout
 (* A layout that is Pgenval because it is the arg of a polymorphic variant *)

lambda/matching.ml

@@ -108,7 +108,7 @@ let jkind_layout_default_to_value_and_check_not_void loc jkind =
   let rec contains_void : Jkind.Layout.Const.t -> bool = function
     | Any -> false
     | Base Void -> true
-    | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64) -> false
+    | Base (Value | Float64 | Float32 | Word | Bits32 | Bits64 | Vec128) -> false
     | Product [] ->
       Misc.fatal_error "nil in jkind_layout_default_to_value_and_check_not_void"
     | Product ts -> List.exists contains_void ts

lambda/printlambda.ml

@@ -137,6 +137,9 @@ let boxed_float_name = function
   | Pfloat64 -> "float"
   | Pfloat32 -> "float32"
 
+let boxed_vector_name = function
+  | Pvec128 -> "vec128"
+
 let constructor_shape print_value_kind ppf shape =
   let value_fields, flat_fields  =
     match shape with
@@ -179,7 +182,7 @@ let rec value_kind ppf = function
   | Pboxedfloatval bf -> fprintf ppf "[%s]" (boxed_float_name bf)
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-  | Pboxedvectorval (Pvec128 v) -> fprintf ppf "[%s]" (vec128_name v)
+  | Pboxedvectorval bv -> fprintf ppf "[%s]" (boxed_vector_name bv)
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
@@ -189,7 +192,7 @@ and value_kind' ppf = function
   | Pboxedfloatval bf -> fprintf ppf "[%s]" (boxed_float_name bf)
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-  | Pboxedvectorval (Pvec128 v) -> fprintf ppf "[%s]" (vec128_name v)
+  | Pboxedvectorval bv -> fprintf ppf "[%s]" (boxed_vector_name bv)
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
@@ -200,7 +203,7 @@ let rec layout' is_top ppf layout_ =
   | Pbottom -> fprintf ppf "[bottom]"
   | Punboxed_float bf -> fprintf ppf "[unboxed_%s]" (boxed_float_name bf)
   | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi)
-  | Punboxed_vector (Pvec128 v) -> fprintf ppf "[unboxed_%s]" (vec128_name v)
+  | Punboxed_vector bv -> fprintf ppf "[unboxed_%s]" (boxed_vector_name bv)
   | Punboxed_product layouts ->
     fprintf ppf "@[<hov 1>#(%a)@]"
       (pp_print_list ~pp_sep:(fun ppf () -> fprintf ppf ",@ ") (layout' false))
@@ -219,13 +222,12 @@ let return_kind ppf (mode, kind) =
   | Pvalue (Parrayval elt_kind) ->
      fprintf ppf ": %s%sarray@ " smode (array_kind elt_kind)
   | Pvalue (Pboxedintval bi) -> fprintf ppf ": %s%s@ " smode (boxed_integer_name bi)
-  | Pvalue (Pboxedvectorval (Pvec128 v)) ->
-    fprintf ppf ": %s%s@ " smode (vec128_name v)
+  | Pvalue (Pboxedvectorval bv) -> fprintf ppf ": %s%s@ " smode (boxed_vector_name bv)
   | Pvalue (Pvariant { consts; non_consts; }) ->
     variant_kind value_kind' ppf ~consts ~non_consts
   | Punboxed_float bf -> fprintf ppf ": unboxed_%s@ " (boxed_float_name bf)
   | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi)
-  | Punboxed_vector (Pvec128 v) -> fprintf ppf ": unboxed_%s@ " (vec128_name v)
+  | Punboxed_vector bv -> fprintf ppf ": unboxed_%s@ " (boxed_vector_name bv)
   | Punboxed_product _ -> fprintf ppf ": %a" layout kind
   | Ptop -> fprintf ppf ": top@ "
   | Pbottom -> fprintf ppf ": bottom@ "
@@ -236,7 +238,7 @@ let field_kind ppf = function
   | Pboxedfloatval bf -> pp_print_string ppf (boxed_float_name bf)
   | Parrayval elt_kind -> fprintf ppf "%s-array" (array_kind elt_kind)
   | Pboxedintval bi -> pp_print_string ppf (boxed_integer_name bi)
-  | Pboxedvectorval (Pvec128 v) -> pp_print_string ppf (vec128_name v)
+  | Pboxedvectorval bv -> pp_print_string ppf (boxed_vector_name bv)
   | Pvariant { consts; non_consts; } ->
     fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
       (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
@@ -819,7 +821,9 @@ let primitive ppf = function
   | Punbox_int bi -> fprintf ppf "unbox_%s" (boxed_integer_name bi)
   | Pbox_int (bi, m) ->
       fprintf ppf "box_%s%s" (boxed_integer_name bi) (locality_kind m)
-
+  | Punbox_vector bi -> fprintf ppf "unbox_%s" (boxed_vector_name bi)
+  | Pbox_vector (bi, m) ->
+      fprintf ppf "box_%s%s" (boxed_vector_name bi) (locality_kind m)
   | Parray_to_iarray -> fprintf ppf "array_to_iarray"
   | Parray_of_iarray -> fprintf ppf "array_of_iarray"
   | Pget_header m -> fprintf ppf "get_header%s" (locality_kind m)
@@ -990,6 +994,8 @@ let name_of_primitive = function
   | Pbox_float (_, _) -> "Pbox_float"
   | Punbox_int _ -> "Punbox_int"
   | Pbox_int _ -> "Pbox_int"
+  | Punbox_vector _ -> "Punbox_vector"
+  | Pbox_vector _ -> "Pbox_vector"
   | Parray_of_iarray -> "Parray_of_iarray"
   | Parray_to_iarray -> "Parray_to_iarray"
   | Pget_header _ -> "Pget_header"

lambda/tmc.ml

@@ -904,6 +904,7 @@ let rec choice ctx t =
     | Patomic_exchange | Patomic_cas | Patomic_fetch_add | Patomic_load _
     | Punbox_float _ | Pbox_float (_, _)
     | Punbox_int _ | Pbox_int _
+    | Punbox_vector _ | Pbox_vector (_, _)
 
     (* we don't handle array indices as destinations yet *)
     | (Pmakearray _ | Pduparray _)

lambda/translcore.ml

@@ -56,7 +56,7 @@ let layout_pat sort p = layout p.pat_env p.pat_loc sort p.pat_type
 
 let check_record_field_sort loc sort =
   match Jkind.Sort.default_to_value_and_get sort with
-  | Base (Value | Float64 | Float32 | Bits32 | Bits64 | Word) -> ()
+  | Base (Value | Float64 | Float32 | Bits32 | Bits64 | Vec128 | Word) -> ()
   | Base Void -> raise (Error (loc, Illegal_void_record_field))
   | Product _ as c -> raise (Error (loc, Illegal_product_record_field c))