flambda-backend: 128-bit vector primitive types (#1568)

lambda/lambda.ml

@@ -291,8 +291,17 @@ and array_set_kind =
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
-and boxed_vector = Primitive.boxed_vector =
-  | Pvec128
+and vec128_type =
+  | Unknown128
+  | Int8x16
+  | Int16x8
+  | Int32x4
+  | Int64x2
+  | Float32x4
+  | Float64x2
+
+and boxed_vector =
+  | Pvec128 of vec128_type
 
 and bigarray_kind =
     Pbigarray_unknown
@@ -313,23 +322,44 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
-let equal_boxed_integer = Primitive.equal_boxed_integer
+let vec128_name = function
+  | Unknown128 -> "unknown128"
+  | Int8x16 -> "int8x16"
+  | Int16x8 -> "int16x8"
+  | Int32x4 -> "int32x4"
+  | Int64x2 -> "int64x2"
+  | Float32x4 -> "float32x4"
+  | Float64x2 -> "float64x2"
 
-let equal_boxed_vector = Primitive.equal_boxed_vector
+let equal_boxed_integer = Primitive.equal_boxed_integer
 
-let equal_primitive =
-  (* Should be implemented like [equal_value_kind] of [equal_boxed_integer],
-     i.e. by matching over the various constructors but the type has more
-     than 100 constructors... *)
-  (=)
+let equal_boxed_vector_size v1 v2 =
+  match v1, v2 with
+  | Pvec128 _, Pvec128 _ -> true
+
+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))
 
 let rec equal_value_kind x y =
   match x, y with
   | Pgenval, Pgenval -> true
   | Pfloatval, Pfloatval -> true
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
   | Pboxedvectorval bi1, Pboxedvectorval bi2 ->
-    equal_boxed_vector bi1 bi2
+    equal_boxed_vector_size bi1 bi2
   | Pintval, Pintval -> true
   | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2
   | Pvariant { consts = consts1; non_consts = non_consts1; },
@@ -363,7 +393,7 @@ let compatible_layout x y =
   | Punboxed_float, Punboxed_float -> true
   | Punboxed_int bi1, Punboxed_int bi2 ->
       equal_boxed_integer bi1 bi2
-  | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector bi1 bi2
+  | Punboxed_vector bi1, Punboxed_vector bi2 -> equal_boxed_vector_size bi1 bi2
   | Ptop, Ptop -> true
   | Ptop, _ | _, Ptop -> false
   | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _), _ -> false
@@ -652,7 +682,14 @@ let layout_unboxed_float = Punboxed_float
 let layout_string = Pvalue Pgenval
 let layout_boxedint bi = Pvalue (Pboxedintval bi)
 
-let layout_boxed_vector vi = Pvalue (Pboxedvectorval vi)
+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_lazy = Pvalue Pgenval
 let layout_lazy_contents = Pvalue Pgenval
 let layout_any_value = Pvalue Pgenval

lambda/lambda.mli

@@ -253,8 +253,17 @@ and block_shape =
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
-and boxed_vector = Primitive.boxed_vector =
-  | Pvec128
+and vec128_type =
+  | Unknown128
+  | Int8x16
+  | Int16x8
+  | Int32x4
+  | Int64x2
+  | Float32x4
+  | Float64x2
+
+and boxed_vector =
+  | Pvec128 of vec128_type
 
 and bigarray_kind =
     Pbigarray_unknown
@@ -275,7 +284,9 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
-val equal_primitive : primitive -> primitive -> bool
+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
 
@@ -285,7 +296,7 @@ val compatible_layout : layout -> layout -> bool
 
 val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
 
-val equal_boxed_vector : boxed_vector -> boxed_vector -> bool
+val equal_boxed_vector_size : boxed_vector -> boxed_vector -> bool
 
 val must_be_value : layout -> value_kind
 
@@ -537,6 +548,7 @@ val layout_string : layout
 val layout_boxed_float : layout
 val layout_unboxed_float : layout
 val layout_boxedint : boxed_integer -> layout
+val layout_boxed_vector : Primitive.boxed_vector -> layout
 (* A layout that is Pgenval because it is the field of a block *)
 val layout_field : layout
 val layout_lazy : layout

lambda/printlambda.ml

@@ -85,9 +85,6 @@ let boxed_integer_name = function
   | Pint32 -> "int32"
   | Pint64 -> "int64"
 
-let boxed_vector_name = function
-  | Pvec128 -> "vec128"
-
 let variant_kind print_contents ppf ~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)
@@ -108,7 +105,7 @@ let rec value_kind ppf = function
   | Pfloatval -> fprintf ppf "[float]"
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-  | Pboxedvectorval bv -> fprintf ppf "[%s]" (boxed_vector_name bv)
+  | Pboxedvectorval (Pvec128 v) -> fprintf ppf "[%s]" (vec128_name v)
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
@@ -118,7 +115,7 @@ and value_kind' ppf = function
   | Pfloatval -> fprintf ppf "[float]"
   | Parrayval elt_kind -> fprintf ppf "[%sarray]" (array_kind elt_kind)
   | Pboxedintval bi -> fprintf ppf "[%s]" (boxed_integer_name bi)
-  | Pboxedvectorval bv -> fprintf ppf "[%s]" (boxed_vector_name bv)
+  | Pboxedvectorval (Pvec128 v) -> fprintf ppf "[%s]" (vec128_name v)
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
@@ -129,7 +126,7 @@ let layout ppf layout =
   | Pbottom -> fprintf ppf "[bottom]"
   | Punboxed_float -> fprintf ppf "[unboxed_float]"
   | Punboxed_int bi -> fprintf ppf "[unboxed_%s]" (boxed_integer_name bi)
-  | Punboxed_vector bi -> fprintf ppf "[unboxed_%s]" (boxed_vector_name bi)
+  | Punboxed_vector (Pvec128 v) -> fprintf ppf "[unboxed_%s]" (vec128_name v)
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -141,13 +138,13 @@ 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 bv) ->
-    fprintf ppf ": %s%s@ " smode (boxed_vector_name bv)
+  | Pvalue (Pboxedvectorval (Pvec128 v)) ->
+    fprintf ppf ": %s%s@ " smode (vec128_name v)
   | Pvalue (Pvariant { consts; non_consts; }) ->
     variant_kind value_kind' ppf ~consts ~non_consts
   | Punboxed_float -> fprintf ppf ": unboxed_float@ "
   | Punboxed_int bi -> fprintf ppf ": unboxed_%s@ " (boxed_integer_name bi)
-  | Punboxed_vector bi -> fprintf ppf ": unboxed_%s@ " (boxed_vector_name bi)
+  | Punboxed_vector (Pvec128 v) -> fprintf ppf ": unboxed_%s@ " (vec128_name v)
   | Ptop -> fprintf ppf ": top@ "
   | Pbottom -> fprintf ppf ": bottom@ "
 
@@ -157,7 +154,7 @@ let field_kind ppf = function
   | 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)
-  | Pboxedvectorval bv -> pp_print_string ppf (boxed_vector_name bv)
+  | Pboxedvectorval (Pvec128 v) -> pp_print_string ppf (vec128_name v)
   | 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)

middle_end/clambda_primitives.ml

@@ -158,7 +158,7 @@ and value_kind = Lambda.value_kind =
       non_consts : (int * value_kind list) list;
     }
   | Parrayval of array_kind
-  | Pboxedvectorval of boxed_vector 
+  | Pboxedvectorval of boxed_vector
 
 and layout = Lambda.layout =
   | Ptop
@@ -169,11 +169,21 @@ and layout = Lambda.layout =
   | Pbottom
 
 and block_shape = Lambda.block_shape
-and boxed_integer = Primitive.boxed_integer =
+
+and boxed_integer = Lambda.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
-and boxed_vector = Primitive.boxed_vector = 
-  | Pvec128
+and vec128_type = Lambda.vec128_type =
+  | Unknown128
+  | Int8x16
+  | Int16x8
+  | Int32x4
+  | Int64x2
+  | Float32x4
+  | Float64x2
+
+and boxed_vector = Lambda.boxed_vector =
+  | Pvec128 of vec128_type
 
 and bigarray_kind = Lambda.bigarray_kind =
     Pbigarray_unknown

middle_end/clambda_primitives.mli

@@ -161,7 +161,7 @@ and value_kind = Lambda.value_kind =
       non_consts : (int * value_kind list) list;
     }
   | Parrayval of array_kind
-  | Pboxedvectorval of boxed_vector 
+  | Pboxedvectorval of boxed_vector
 
 and layout = Lambda.layout =
   | Ptop
@@ -172,11 +172,21 @@ and layout = Lambda.layout =
   | Pbottom
 
 and block_shape = Lambda.block_shape
-and boxed_integer = Primitive.boxed_integer =
+
+and boxed_integer = Lambda.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
-and boxed_vector = Primitive.boxed_vector = 
-  | Pvec128
+and vec128_type = Lambda.vec128_type =
+  | Unknown128
+  | Int8x16
+  | Int16x8
+  | Int32x4
+  | Int64x2
+  | Float32x4
+  | Float64x2
+
+and boxed_vector = Lambda.boxed_vector =
+  | Pvec128 of vec128_type
 
 and bigarray_kind = Lambda.bigarray_kind =
     Pbigarray_unknown

middle_end/printclambda.ml

@@ -37,7 +37,8 @@ let rec value_kind0 ppf kind =
   | Pboxedintval Pnativeint -> Format.pp_print_string ppf ":nativeint"
   | Pboxedintval Pint32 -> Format.pp_print_string ppf ":int32"
   | Pboxedintval Pint64 -> Format.pp_print_string ppf ":int64"
-  | Pboxedvectorval Pvec128 -> Format.pp_print_string ppf ":vec128"
+  | Pboxedvectorval (Pvec128 ty) ->
+    Format.pp_print_string ppf (":" ^ (vec128_name ty))
   | Pvariant { consts; non_consts } ->
     Format.fprintf ppf "@[<hov 1>[(consts (%a))@ (non_consts (%a))]@]"
       (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_int)
@@ -61,7 +62,8 @@ let layout (layout : Lambda.layout) =
   | Punboxed_int Pint32 -> ":unboxed_int32"
   | Punboxed_int Pint64 -> ":unboxed_int64"
   | Punboxed_int Pnativeint -> ":unboxed_nativeint"
-  | Punboxed_vector Pvec128 -> ":unboxed_vec128"
+  | Punboxed_vector (Pvec128 ty) ->
+    Format.sprintf ":unboxed_%s" (Lambda.vec128_name ty)
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x

testsuite/tests/typing-layouts-float64/basics_alpha.ml

@@ -456,7 +456,7 @@ Line 1, characters 18-24:
 1 | external f10_6 : (float#[@unboxed]) -> bool -> string  = "foo" "bar";;
                       ^^^^^^
 Error: Don't know how to unbox this type.
-       Only float, int32, int64, nativeint, and vec128 can be unboxed.
+       Only float, int32, int64, nativeint, and vector primitives can be unboxed.
 |}];;
 
 external f10_7 : string -> (float#[@unboxed])  = "foo" "bar";;
@@ -465,7 +465,7 @@ Line 1, characters 28-34:
 1 | external f10_7 : string -> (float#[@unboxed])  = "foo" "bar";;
                                 ^^^^^^
 Error: Don't know how to unbox this type.
-       Only float, int32, int64, nativeint, and vec128 can be unboxed.
+       Only float, int32, int64, nativeint, and vector primitives can be unboxed.
 |}];;
 
 external f10_8 : float -> float#  = "foo" "bar" [@@unboxed];;
@@ -474,7 +474,7 @@ Line 1, characters 26-32:
 1 | external f10_8 : float -> float#  = "foo" "bar" [@@unboxed];;
                               ^^^^^^
 Error: Don't know how to unbox this type.
-       Only float, int32, int64, nativeint, and vec128 can be unboxed.
+       Only float, int32, int64, nativeint, and vector primitives can be unboxed.
 |}];;
 
 (*******************************************************)

testsuite/tests/typing-simd/test_disabled.ml

@@ -2,10 +2,53 @@
    * expect
 *)
 
-type t = vec128;;
+type t = int8x16;;
 [%%expect{|
-Line 1, characters 9-15:
-1 | type t = vec128;;
-             ^^^^^^
-Error: Unbound type constructor vec128
+Line 1, characters 9-16:
+1 | type t = int8x16;;
+             ^^^^^^^
+Error: Unbound type constructor int8x16
+|}];;
+
+type t = int16x8;;
+[%%expect{|
+Line 1, characters 9-16:
+1 | type t = int16x8;;
+             ^^^^^^^
+Error: Unbound type constructor int16x8
+Hint: Did you mean int64?
+|}];;
+
+type t = int32x4;;
+[%%expect{|
+Line 1, characters 9-16:
+1 | type t = int32x4;;
+             ^^^^^^^
+Error: Unbound type constructor int32x4
+Hint: Did you mean int32?
+|}];;
+
+type t = int64x2;;
+[%%expect{|
+Line 1, characters 9-16:
+1 | type t = int64x2;;
+             ^^^^^^^
+Error: Unbound type constructor int64x2
+Hint: Did you mean int64?
+|}];;
+
+type t = float32x4;;
+[%%expect{|
+Line 1, characters 9-18:
+1 | type t = float32x4;;
+             ^^^^^^^^^
+Error: Unbound type constructor float32x4
+|}];;
+
+type t = float64x2;;
+[%%expect{|
+Line 1, characters 9-18:
+1 | type t = float64x2;;
+             ^^^^^^^^^
+Error: Unbound type constructor float64x2
 |}];;