128-bit vector primitive types (#1568)

Author: TheNumbat

backend/cmm_helpers.ml

@@ -149,14 +149,10 @@ let alloc_float_header mode dbg =
   | Lambda.Alloc_heap -> Cconst_natint (float_header, dbg)
   | Lambda.Alloc_local -> Cconst_natint (float_local_header, dbg)
 
-let alloc_boxedvector_header vi mode dbg =
-  let header, local_header =
-    match vi with
-    | Primitive.Pvec128 -> boxedvec128_header, boxedvec128_local_header
-  in
+let alloc_boxedvec128_header mode dbg =
   match mode with
-  | Lambda.Alloc_heap -> Cconst_natint (header, dbg)
-  | Lambda.Alloc_local -> Cconst_natint (local_header, dbg)
+  | Lambda.Alloc_heap -> Cconst_natint (boxedvec128_header, dbg)
+  | Lambda.Alloc_local -> Cconst_natint (boxedvec128_local_header, dbg)
 
 let alloc_floatarray_header len dbg = Cconst_natint (floatarray_header len, dbg)
 
@@ -715,8 +711,7 @@ let rec unbox_float dbg =
 
 (* Vectors *)
 
-let box_vector dbg vi m c =
-  Cop (Calloc m, [alloc_boxedvector_header vi m dbg; c], dbg)
+let box_vec128 dbg m c = Cop (Calloc m, [alloc_boxedvec128_header m dbg; c], dbg)
 
 let rec unbox_vec128 dbg =
   map_tail ~kind:Any (function
@@ -745,9 +740,6 @@ let rec unbox_vec128 dbg =
     | Ctail e -> Ctail (unbox_vec128 dbg e)
     | cmm -> Cop (Cload (Onetwentyeight, Immutable), [cmm], dbg))
 
-let unbox_vector dbg vi e =
-  match vi with Primitive.Pvec128 -> unbox_vec128 dbg e
-
 (* Complex *)
 
 let box_complex dbg c_re c_im =
@@ -1128,7 +1120,7 @@ module Extended_machtype = struct
     | Pbottom ->
       Misc.fatal_error "No unique Extended_machtype for layout [Pbottom]"
     | Punboxed_float -> typ_float
-    | Punboxed_vector Pvec128 -> typ_vec128
+    | Punboxed_vector (Pvec128 _) -> typ_vec128
     | Punboxed_int _ ->
       (* Only 64-bit architectures, so this is always [typ_int] *)
       typ_any_int

backend/cmm_helpers.mli

@@ -211,15 +211,9 @@ val box_float : Debuginfo.t -> Lambda.alloc_mode -> expression -> expression
 val unbox_float : Debuginfo.t -> expression -> expression
 
 (** Vector boxing and unboxing *)
-val box_vector :
-  Debuginfo.t ->
-  Primitive.boxed_vector ->
-  Lambda.alloc_mode ->
-  expression ->
-  expression
+val box_vec128 : Debuginfo.t -> Lambda.alloc_mode -> expression -> expression
 
-val unbox_vector :
-  Debuginfo.t -> Primitive.boxed_vector -> expression -> expression
+val unbox_vec128 : Debuginfo.t -> expression -> expression
 
 (** Complex number creation and access *)
 val box_complex : Debuginfo.t -> expression -> expression -> expression

backend/cmmgen.ml

@@ -163,7 +163,7 @@ let get_field env layout ptr n dbg =
     | Pvalue Pintval | Punboxed_int _ -> Word_int
     | Pvalue _ -> Word_val
     | Punboxed_float -> Double
-    | Punboxed_vector Pvec128 -> Onetwentyeight
+    | Punboxed_vector (Pvec128 _) -> Onetwentyeight
     | Ptop ->
         Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg
     | Pbottom ->
@@ -323,7 +323,7 @@ let typ_of_boxed_number = function
   | Boxed_float _ -> Cmm.typ_float
   | Boxed_integer (Pint64, _,_) when size_int = 4 -> [|Int;Int|]
   | Boxed_integer _ -> Cmm.typ_int
-  | Boxed_vector (Pvec128, _, _) -> Cmm.typ_vec128
+  | Boxed_vector (Pvec128 _, _, _) -> Cmm.typ_vec128
 
 let equal_unboxed_integer ui1 ui2 =
   match ui1, ui2 with
@@ -343,7 +343,7 @@ let box_number bn arg =
   match bn with
   | Boxed_float (m, dbg) -> box_float dbg m arg
   | Boxed_integer (bi, m, dbg) -> box_int dbg bi m arg
-  | Boxed_vector (vi, m, dbg) -> box_vector dbg vi m arg
+  | Boxed_vector (Pvec128 _, m, dbg) -> box_vec128 dbg m arg
 
 (* Returns the unboxed representation of a boxed float or integer.
    For Pint32 on 64-bit archs, the high 32 bits of the result are undefined. *)
@@ -355,8 +355,8 @@ let unbox_number dbg bn arg =
     low_32 dbg (unbox_int dbg Pint32 arg)
   | Boxed_integer (bi, _, _) ->
     unbox_int dbg bi arg
-  | Boxed_vector (vi, _, _) ->
-    unbox_vector dbg vi arg
+  | Boxed_vector (Pvec128 _, _, _) ->
+    unbox_vec128 dbg arg
 
 (* Auxiliary functions for optimizing "let" of boxed numbers (floats and
    boxed integers *)
@@ -438,7 +438,7 @@ let rec is_unboxed_number_cmm = function
         | Some (Uconst_int64 _) ->
           Boxed (Boxed_integer (Pint64, alloc_heap, Debuginfo.none), true)
         | Some (Uconst_vec128 _) ->
-          Boxed (Boxed_vector (Pvec128, alloc_heap, Debuginfo.none), true)
+          Boxed (Boxed_vector (Pvec128 Unknown128, alloc_heap, Debuginfo.none), true)
         | _ ->
           No_unboxing
       end
@@ -932,12 +932,8 @@ and transl_ccall env prim args dbg =
           | Pint32 -> XInt32
           | Pint64 -> XInt64 in
         (xty, transl_unbox_int dbg env bi arg)
-        | Unboxed_vector bi ->
-          let xty =
-            match bi with
-            | Pvec128 -> XVec128
-          in
-          (xty, transl_unbox_vector dbg env bi arg)
+    | Unboxed_vector (Pvec128 _) ->
+        (XVec128, transl_unbox_vec128 dbg env arg)
     | Untagged_int ->
         (XInt, untag_int (transl env arg) dbg)
   in
@@ -962,7 +958,7 @@ and transl_ccall env prim args dbg =
     | _, Unboxed_integer Pint64 when size_int = 4 ->
         ([|Int; Int|], box_int dbg Pint64 alloc_heap)
     | _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap)
-    | _, Unboxed_vector Pvec128 -> (typ_vec128, box_vector dbg Pvec128 alloc_heap)
+    | _, Unboxed_vector (Pvec128 _) -> (typ_vec128, box_vec128 dbg alloc_heap)
     | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
   in
   let typ_args, args = transl_args prim.prim_native_repr_args args in
@@ -1307,8 +1303,8 @@ and transl_unbox_float dbg env exp =
 and transl_unbox_int dbg env bi exp =
   unbox_int dbg bi (transl env exp)
 
-and transl_unbox_vector dbg env bi exp =
-  unbox_vector dbg bi (transl env exp)
+and transl_unbox_vec128 dbg env exp =
+  unbox_vec128 dbg (transl env exp)
 
 (* transl_unbox_int, but may return garbage in upper bits *)
 and transl_unbox_int_low dbg env bi e =

middle_end/clambda.ml

@@ -229,7 +229,8 @@ let compare_structured_constants c1 c2 =
   | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
   | Uconst_closure (_,lbl1,_), Uconst_closure (_,lbl2,_) ->
       String.compare lbl1 lbl2
-  | Uconst_vec128 {high = l0; low = l1}, Uconst_vec128 {high = r0; low = r1} ->
+  | Uconst_vec128 { high = l0; low = l1},
+    Uconst_vec128 { high = r0; low = r1} ->
     let cmp = Int64.compare l0 r0 in
     if cmp = 0 then Int64.compare l1 r1 else cmp
   | _, _ ->

middle_end/clambda_primitives.ml

@@ -172,8 +172,17 @@ and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.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

@@ -176,8 +176,17 @@ and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.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/flambda2/from_lambda/closure_conversion.ml

@@ -448,7 +448,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
       Some (P.Box_number (Naked_int32, Alloc_mode.For_allocations.heap))
     | _, Unboxed_integer Pint64 ->
       Some (P.Box_number (Naked_int64, Alloc_mode.For_allocations.heap))
-    | _, Unboxed_vector Pvec128 ->
+    | _, Unboxed_vector (Pvec128 _) ->
       Some (P.Box_number (Naked_vec128, Alloc_mode.For_allocations.heap))
     | _, Untagged_int -> Some P.Tag_immediate
   in
@@ -473,7 +473,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
     | Unboxed_integer Pint32 -> K.naked_int32
     | Unboxed_integer Pint64 -> K.naked_int64
     | Untagged_int -> K.naked_immediate
-    | Unboxed_vector Pvec128 -> K.naked_vec128
+    | Unboxed_vector (Pvec128 _) -> K.naked_vec128
   in
   let param_arity =
     List.map kind_of_primitive_native_repr prim_native_repr_args
@@ -560,7 +560,7 @@ let close_c_call acc env ~loc ~let_bound_ids_with_kinds
           | _, Unboxed_integer Pint32 -> Some (P.Unbox_number Naked_int32)
           | _, Unboxed_integer Pint64 -> Some (P.Unbox_number Naked_int64)
           | _, Untagged_int -> Some P.Untag_immediate
-          | _, Unboxed_vector Pvec128 -> Some (P.Unbox_number Naked_vec128)
+          | _, Unboxed_vector (Pvec128 _) -> Some (P.Unbox_number Naked_vec128)
         in
         match unbox_arg with
         | None -> fun args acc -> call (arg :: args) acc

middle_end/flambda2/identifiers/int_ids.ml

@@ -48,7 +48,7 @@ module Const_data = struct
     | Naked_int32 of Int32.t
     | Naked_int64 of Int64.t
     | Naked_nativeint of Targetint_32_64.t
-    | Naked_vec128 of Numeric_types.Vec128_by_bit_pattern.t
+    | Naked_vec128 of Vector_types.Vec128.Bit_pattern.t
 
   let flags = const_flags
 
@@ -87,10 +87,10 @@ module Const_data = struct
           Flambda_colours.naked_number
           Targetint_32_64.print n
           Flambda_colours.pop
-      | Naked_vec128 v ->
-        Format.fprintf ppf "%t#%a%t"
+      | Naked_vec128 (v) ->
+        Format.fprintf ppf "%t#vec128[%a]%t"
           Flambda_colours.naked_number
-          Numeric_types.Vec128_by_bit_pattern.print v
+          Vector_types.Vec128.Bit_pattern.print v
           Flambda_colours.pop
 
     let compare t1 t2 =
@@ -104,7 +104,7 @@ module Const_data = struct
       | Naked_int64 n1, Naked_int64 n2 -> Int64.compare n1 n2
       | Naked_nativeint n1, Naked_nativeint n2 -> Targetint_32_64.compare n1 n2
       | Naked_vec128 v1, Naked_vec128 v2 ->
-        Numeric_types.Vec128_by_bit_pattern.compare v1 v2
+        Vector_types.Vec128.Bit_pattern.compare v1 v2
       | Naked_immediate _, _ -> -1
       | _, Naked_immediate _ -> 1
       | Tagged_immediate _, _ -> -1
@@ -132,7 +132,7 @@ module Const_data = struct
         | Naked_int64 n1, Naked_int64 n2 -> Int64.equal n1 n2
         | Naked_nativeint n1, Naked_nativeint n2 -> Targetint_32_64.equal n1 n2
         | Naked_vec128 v1, Naked_vec128 v2 ->
-          Numeric_types.Vec128_by_bit_pattern.equal v1 v2
+          Vector_types.Vec128.Bit_pattern.equal v1 v2
         | ( ( Naked_immediate _ | Tagged_immediate _ | Naked_float _
             | Naked_vec128 _ | Naked_int32 _ | Naked_int64 _ | Naked_nativeint _
               ),
@@ -147,7 +147,7 @@ module Const_data = struct
       | Naked_int32 n -> Hashtbl.hash n
       | Naked_int64 n -> Hashtbl.hash n
       | Naked_nativeint n -> Targetint_32_64.hash n
-      | Naked_vec128 v -> Numeric_types.Vec128_by_bit_pattern.hash v
+      | Naked_vec128 v -> Vector_types.Vec128.Bit_pattern.hash v
   end)
 end
 

middle_end/flambda2/identifiers/int_ids.mli

@@ -60,7 +60,7 @@ module Const : sig
 
   val naked_nativeint : Targetint_32_64.t -> t
 
-  val naked_vec128 : Numeric_types.Vec128_by_bit_pattern.t -> t
+  val naked_vec128 : Vector_types.Vec128.Bit_pattern.t -> t
 
   module Descr : sig
     type t = private
@@ -70,7 +70,7 @@ module Const : sig
       | Naked_int32 of Int32.t
       | Naked_int64 of Int64.t
       | Naked_nativeint of Targetint_32_64.t
-      | Naked_vec128 of Numeric_types.Vec128_by_bit_pattern.t
+      | Naked_vec128 of Vector_types.Vec128.Bit_pattern.t
 
     include Container_types.S with type t := t
   end

middle_end/flambda2/kinds/flambda_kind.ml

@@ -70,7 +70,7 @@ let to_lambda (t : t) : Lambda.layout =
   | Naked_number Naked_int32 -> Punboxed_int Pint32
   | Naked_number Naked_int64 -> Punboxed_int Pint64
   | Naked_number Naked_nativeint -> Punboxed_int Pnativeint
-  | Naked_number Naked_vec128 -> Punboxed_vector Pvec128
+  | Naked_number Naked_vec128 -> Punboxed_vector (Pvec128 Unknown128)
   | Region -> Misc.fatal_error "Can't convert kind [Region] to lambda layout"
   | Rec_info ->
     Misc.fatal_error "Can't convert kind [Rec_info] to lambda layout"
@@ -278,7 +278,7 @@ module Boxable_number = struct
     | Naked_int32 -> Format.pp_print_string ppf "naked_int32"
     | Naked_int64 -> Format.pp_print_string ppf "naked_int64"
     | Naked_nativeint -> Format.pp_print_string ppf "naked_nativeint"
-    | Naked_vec128 -> Format.pp_print_string ppf "naked_vec128"
+    | Naked_vec128 -> Format.fprintf ppf "naked_vec128"
 
   let print_lowercase_short ppf t =
     match t with
@@ -528,7 +528,7 @@ module With_subkind = struct
     | Pboxedintval Pint32 -> boxed_int32
     | Pboxedintval Pint64 -> boxed_int64
     | Pboxedintval Pnativeint -> boxed_nativeint
-    | Pboxedvectorval Pvec128 -> boxed_vec128
+    | Pboxedvectorval (Pvec128 _) -> boxed_vec128
     | Pintval -> tagged_immediate
     | Pvariant { consts; non_consts } -> (
       match consts, non_consts with
@@ -570,7 +570,7 @@ module With_subkind = struct
     | Punboxed_int Pint32 -> naked_int32
     | Punboxed_int Pint64 -> naked_int64
     | Punboxed_int Pnativeint -> naked_nativeint
-    | Punboxed_vector Pvec128 -> naked_vec128
+    | Punboxed_vector (Pvec128 _) -> naked_vec128
 
   include Container_types.Make (struct
     type nonrec t = t

middle_end/flambda2/numbers/numeric_types.ml

@@ -250,65 +250,3 @@ module Int64 = struct
 
   let cross_product = Pair.create_from_cross_product
 end
-
-module type Vector_width = sig
-  val size_in_int64s : int
-end
-
-module Vector_by_bit_pattern (Width : Vector_width) = struct
-  module T0 = struct
-    type t = Int64.t Array.t
-
-    let rec compare l r i =
-      if i = Width.size_in_int64s
-      then 0
-      else
-        let cmp = Int64.compare l.(i) r.(i) in
-        if cmp = 0 then compare l r (i + 1) else cmp
-
-    let compare l r = compare l r 0
-
-    let equal = Array.for_all2 Int64.equal
-
-    let hash v = Hashtbl.hash v
-
-    let print ppf t =
-      Format.pp_print_list
-        ~pp_sep:(fun ppf () -> Format.pp_print_char ppf ':')
-        (fun ppf i64 -> Format.fprintf ppf "%016Lx" i64)
-        ppf (Array.to_list t)
-  end
-
-  include T0
-  module Self = Container_types.Make (T0)
-  include Self
-
-  let zero = Array.init Width.size_in_int64s (fun _ -> 0L)
-
-  let to_int64_array t = t
-
-  let of_int64_array t =
-    if not (Array.length t = Width.size_in_int64s)
-    then
-      Misc.fatal_error
-        "Vector_by_bit_pattern.of_int64_array: wrong length array";
-    t
-end
-
-module Vec128_by_bit_pattern = struct
-  include Vector_by_bit_pattern (struct
-    let size_in_int64s = 2
-  end)
-
-  type bits =
-    { high : int64;
-      low : int64
-    }
-
-  let to_bits t =
-    match to_int64_array t with
-    | [| high; low |] -> { high; low }
-    | _ -> Misc.fatal_error "Vec128.to_bits: wrong size vector"
-
-  let of_bits { high; low } = of_int64_array [| high; low |]
-end