flambda-backend: 128-bit SIMD vector primitive type (#1499)

Author: TheNumbat

Makefile.common-jst

@@ -198,6 +198,9 @@ install_for_test: _install
 	 # replace backend-specific testsuite/tests/asmgen with their new versions
 	rm _runtest/testsuite/tests/asmgen/*
 	cp -a testsuite/tests/asmgen/* _runtest/testsuite/tests/asmgen/
+	 # replace backend-specific testsuite/tests/unboxed-primitive-args with their new versions
+	rm _runtest/testsuite/tests/unboxed-primitive-args/*
+	cp -a testsuite/tests/unboxed-primitive-args/* _runtest/testsuite/tests/unboxed-primitive-args/
 
 	cp $(ocamldir)/Makefile.* _runtest/
 

asmcomp/amd64/emit.mlp

@@ -1210,7 +1210,7 @@ let probe_env p =
   env.stack_offset <- p.probe_stack_offset;
   (* Account for the return address that is now pushed on the stack. *)
   env.stack_offset <- env.stack_offset + 8;
-  env  
+  env
 
 let emit_probe_handler_wrapper p =
   let wrap_label = probe_handler_wrapper_name p.probe_label in

asmcomp/cmm_helpers.ml

@@ -919,6 +919,8 @@ module Extended_machtype = struct
       (* Only 64-bit architectures, so this is always [typ_int] *)
       typ_any_int
     | Pvalue Pintval -> typ_tagged_int
+    | Punboxed_vector _ ->
+      Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
     | Pvalue _ -> typ_val
 end
 
@@ -3283,5 +3285,8 @@ let kind_of_layout (layout : Lambda.layout) =
   | Pvalue (Pboxedintval bi) -> Boxed_integer bi
   | Pvalue (Pgenval | Pintval | Pvariant _ | Parrayval _)
   | Ptop | Pbottom | Punboxed_float | Punboxed_int _ -> Any
+  | Pvalue (Pboxedvectorval _)
+  | Punboxed_vector _ ->
+    Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
 
 let make_tuple l = match l with [e] -> e | _ -> Ctuple l

asmcomp/cmmgen.ml

@@ -124,6 +124,8 @@ let get_field env layout ptr n dbg =
     | Pvalue Pintval | Punboxed_int _ -> Word_int
     | Pvalue _ -> Word_val
     | Punboxed_float -> Double
+    | Punboxed_vector _ ->
+      Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
     | Ptop ->
         Misc.fatal_errorf "get_field with Ptop: %a" Debuginfo.print_compact dbg
     | Pbottom ->
@@ -842,6 +844,8 @@ and transl_ccall env prim args dbg =
           | Pint32 -> XInt32
           | Pint64 -> XInt64 in
         (xty, transl_unbox_int dbg env bi arg)
+    | Unboxed_vector _ ->
+      Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
     | Untagged_int ->
         (XInt, untag_int (transl env arg) dbg)
   in
@@ -871,6 +875,8 @@ and transl_ccall env prim args dbg =
         ([|Int; Int|], box_int dbg Pint64 alloc_heap)
     | _, Unboxed_integer bi -> (typ_int, box_int dbg bi alloc_heap)
     | _, Untagged_int -> (typ_int, (fun i -> tag_int i dbg))
+    | _, Unboxed_vector _ ->
+      Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
   in
   let typ_args, args = transl_args prim.prim_native_repr_args args in
   wrap_result
@@ -1244,6 +1250,8 @@ and transl_let_value env str (kind : Lambda.value_kind) id exp transl_body =
         Boxed (Boxed_float (alloc_heap, dbg), false)
     | Mutable, Pboxedintval bi ->
         Boxed (Boxed_integer (bi, alloc_heap, dbg), false)
+    | _, Pboxedvectorval _ ->
+        Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
     | _, (Pfloatval | Pboxedintval _) ->
         (* It would be safe to always unbox in this case, but
            we do it only if this indeed allows us to get rid of
@@ -1290,6 +1298,8 @@ and transl_let env str (layout : Lambda.layout) id exp transl_body =
          there may be constant closures inside that need lifting out. *)
       let _cbody : expression = transl_body env in
       cexp
+  | Punboxed_vector _ ->
+      Misc.fatal_error "SIMD vectors are not yet suppored in the upstream compiler build."
   | Punboxed_float | Punboxed_int _ -> begin
       let cexp = transl env exp in
       let cbody = transl_body env in

boot/ocamlc

@@ -260,12 +260,14 @@ and value_kind =
       non_consts : (int * value_kind list) list;
     }
   | Parrayval of array_kind
+  | Pboxedvectorval of boxed_vector
 
 and layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
   | Punboxed_int of boxed_integer
+  | Punboxed_vector of boxed_vector
   | Pbottom
 
 and block_shape =
@@ -289,6 +291,9 @@ and array_set_kind =
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
+and boxed_vector = Primitive.boxed_vector =
+  | Pvec128
+
 and bigarray_kind =
     Pbigarray_unknown
   | Pbigarray_float32 | Pbigarray_float64
@@ -310,6 +315,8 @@ and raise_kind =
 
 let equal_boxed_integer = Primitive.equal_boxed_integer
 
+let equal_boxed_vector = Primitive.equal_boxed_vector
+
 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
@@ -321,6 +328,8 @@ let rec equal_value_kind x y =
   | Pgenval, Pgenval -> true
   | Pfloatval, Pfloatval -> true
   | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
+  | Pboxedvectorval bi1, Pboxedvectorval bi2 ->
+    equal_boxed_vector bi1 bi2
   | Pintval, Pintval -> true
   | Parrayval elt_kind1, Parrayval elt_kind2 -> elt_kind1 = elt_kind2
   | Pvariant { consts = consts1; non_consts = non_consts1; },
@@ -337,7 +346,7 @@ let rec equal_value_kind x y =
              && List.for_all2 equal_value_kind fields1 fields2)
            non_consts1 non_consts2
   | (Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _
-      | Parrayval _), _ -> false
+      | Parrayval _ | Pboxedvectorval _), _ -> false
 
 let equal_layout x y =
   match x, y with
@@ -354,9 +363,10 @@ 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
   | Ptop, Ptop -> true
   | Ptop, _ | _, Ptop -> false
-  | (Pvalue _ | Punboxed_float | Punboxed_int _), _ -> false
+  | (Pvalue _ | Punboxed_float | Punboxed_int _ | Punboxed_vector _), _ -> false
 
 let must_be_value layout =
   match layout with
@@ -640,6 +650,8 @@ let layout_functor = Pvalue Pgenval
 let layout_boxed_float = Pvalue Pfloatval
 let layout_string = Pvalue Pgenval
 let layout_boxedint bi = Pvalue (Pboxedintval bi)
+
+let layout_boxed_vector vi = Pvalue (Pboxedvectorval vi)
 let layout_lazy = Pvalue Pgenval
 let layout_lazy_contents = Pvalue Pgenval
 let layout_any_value = Pvalue Pgenval
@@ -1442,6 +1454,7 @@ let primitive_result_layout (p : primitive) =
   | Pbox_float _ -> layout_boxed_float
   | Punbox_float -> Punboxed_float
   | Pccall { prim_native_repr_res = _, Untagged_int; _} -> layout_int
+  | Pccall { prim_native_repr_res = _, Unboxed_vector v; _} -> layout_boxed_vector v
   | Pccall { prim_native_repr_res = _, Unboxed_float; _} -> layout_boxed_float
   | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr s; _} ->
       begin match s with

boot/ocamllex

@@ -235,6 +235,7 @@ and value_kind =
           expected to be significant. *)
     }
   | Parrayval of array_kind
+  | Pboxedvectorval of boxed_vector
 
 (* Because we check for and error on void in the translation to lambda, we don't
    need a constructor for it here. *)
@@ -243,6 +244,7 @@ and layout =
   | Pvalue of value_kind
   | Punboxed_float
   | Punboxed_int of boxed_integer
+  | Punboxed_vector of boxed_vector
   | Pbottom
 
 and block_shape =
@@ -251,6 +253,9 @@ and block_shape =
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
+and boxed_vector = Primitive.boxed_vector =
+  | Pvec128
+
 and bigarray_kind =
     Pbigarray_unknown
   | Pbigarray_float32 | Pbigarray_float64
@@ -280,6 +285,8 @@ 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 must_be_value : layout -> value_kind
 
 type structured_constant =

lambda/lambda.ml

@@ -85,6 +85,9 @@ 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)
@@ -105,6 +108,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)
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
@@ -114,6 +118,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)
   | Pvariant { consts; non_consts; } ->
     variant_kind value_kind' ppf ~consts ~non_consts
 
@@ -124,6 +129,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)
 
 let return_kind ppf (mode, kind) =
   let smode = alloc_mode mode in
@@ -135,10 +141,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 (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)
   | Ptop -> fprintf ppf ": top@ "
   | Pbottom -> fprintf ppf ": bottom@ "
 
@@ -148,6 +157,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)
   | 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)

lambda/lambda.mli

@@ -158,18 +158,23 @@ and value_kind = Lambda.value_kind =
       non_consts : (int * value_kind list) list;
     }
   | Parrayval of array_kind
+  | Pboxedvectorval of boxed_vector 
 
 and layout = Lambda.layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
   | Punboxed_int of boxed_integer
+  | Punboxed_vector of boxed_vector
   | Pbottom
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
+and boxed_vector = Primitive.boxed_vector = 
+  | Pvec128
+
 and bigarray_kind = Lambda.bigarray_kind =
     Pbigarray_unknown
   | Pbigarray_float32 | Pbigarray_float64

lambda/printlambda.ml

@@ -161,18 +161,23 @@ and value_kind = Lambda.value_kind =
       non_consts : (int * value_kind list) list;
     }
   | Parrayval of array_kind
+  | Pboxedvectorval of boxed_vector 
 
 and layout = Lambda.layout =
   | Ptop
   | Pvalue of value_kind
   | Punboxed_float
   | Punboxed_int of boxed_integer
+  | Punboxed_vector of boxed_vector
   | Pbottom
 
 and block_shape = Lambda.block_shape
 and boxed_integer = Primitive.boxed_integer =
     Pnativeint | Pint32 | Pint64
 
+and boxed_vector = Primitive.boxed_vector = 
+  | Pvec128
+
 and bigarray_kind = Lambda.bigarray_kind =
     Pbigarray_unknown
   | Pbigarray_float32 | Pbigarray_float64

middle_end/clambda_primitives.ml

@@ -63,8 +63,10 @@ let is_gc_ignorable kind =
   | Pbottom -> Misc.fatal_error "[Pbottom] should not be stored in a closure."
   | Punboxed_float -> true
   | Punboxed_int _ -> true
+  | Punboxed_vector _ -> true
   | Pvalue Pintval -> true
-  | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _) -> false
+  | Pvalue (Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _ |
+            Pboxedvectorval _) -> false
 
 let split_closure_fv kinds fv =
   List.fold_right (fun id (not_scanned, scanned) ->

middle_end/clambda_primitives.mli

@@ -79,6 +79,7 @@ let add_closure_offsets
              and not stored in a closure."
         | Punboxed_float -> true
         | Punboxed_int _ -> true
+        | Punboxed_vector _ -> true
         | Pvalue Pintval -> true
         | Pvalue _ -> false)
       free_vars

middle_end/closure/closure.ml

@@ -710,6 +710,7 @@ and to_clambda_set_of_closures t env
              and not stored in a closure."
         | Punboxed_float -> true
         | Punboxed_int _ -> true
+        | Punboxed_vector _ -> true
         | Pvalue Pintval -> true
         | Pvalue _ -> false)
       free_vars

middle_end/flambda/closure_offsets.ml

@@ -37,6 +37,7 @@ 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"
   | 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)
@@ -60,6 +61,7 @@ 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"
 
 let rec structured_constant ppf = function
   | Uconst_float x -> fprintf ppf "%F" x