Swap simd flag to language extension

backend/amd64/arch.ml

@@ -31,9 +31,6 @@ let prefetchwt1_support = ref false
 (* Emit elf notes with trap handling information. *)
 let trap_notes = ref true
 
-(* Enables usage of vector registers. *)
-let simd_regalloc_support = ref false
-
 (* Machine-specific command-line options *)
 
 let command_line_options =
@@ -61,11 +58,7 @@ let command_line_options =
     "-ftrap-notes", Arg.Set trap_notes,
       " Emit .note.ocaml_eh section with trap handling information (default)";
     "-fno-trap-notes", Arg.Clear trap_notes,
-      " Do not emit .note.ocaml_eh section with trap handling information";
-    "-fsimd", Arg.Set simd_regalloc_support,
-      " Enable register allocation for SIMD vectors";
-    "-fno-simd", Arg.Clear simd_regalloc_support,
-      " Disable register allocation for SIMD vectors (default)"
+      " Do not emit .note.ocaml_eh section with trap handling information"
   ]
 
 (* Specific operations for the AMD64 processor *)

backend/amd64/emit.mlp

@@ -41,6 +41,8 @@ let _label s = D.label ~typ:QWORD s
 
 (* Override proc.ml *)
 
+let simd_regalloc_disabled () = not (Language_extension.is_enabled SIMD)
+
 let int_reg_name =
   [| RAX; RBX; RDI; RSI; RDX; RCX; R8; R9;
      R12; R13; R10; R11; RBP; |]
@@ -52,7 +54,7 @@ let register_name typ r =
   | Int | Val | Addr -> Reg64 (int_reg_name.(r))
   | Float -> Regf (float_reg_name.(r - 100))
   | Vec128 ->
-    if not !simd_regalloc_support then
+    if simd_regalloc_disabled () then
     Misc.fatal_error "SIMD register allocation is not enabled.";
     Regf (float_reg_name.(r - 100))
 
@@ -93,7 +95,7 @@ let frame_required = ref false
 
 let frame_size () =                     (* includes return address *)
   if !frame_required then begin
-    if not !simd_regalloc_support then assert (num_stack_slots.(2) = 0);
+    if simd_regalloc_disabled () then assert (num_stack_slots.(2) = 0);
     let sz =
       (!stack_offset
        + 8
@@ -109,7 +111,7 @@ let slot_offset loc cl =
   match loc with
   | Incoming n -> frame_size() + n
   | Local n ->
-      if not !simd_regalloc_support then assert (num_stack_slots.(2) = 0 && cl < 2);
+      if simd_regalloc_disabled () then assert (num_stack_slots.(2) = 0 && cl < 2);
       (!stack_offset +
         (* Preserves original ordering (int -> float) *)
         match cl with
@@ -1631,7 +1633,7 @@ let make_stack_loc ~offset n (r : Reg.t) =
   (match r.typ with
    | Int | Val | Addr | Float -> ()
    | Vec128 ->
-    if not !simd_regalloc_support then
+    if simd_regalloc_disabled () then
     Misc.fatal_error "SIMD register allocation is not enabled.");
   Reg.at_location r.typ loc
 

backend/amd64/proc.ml

@@ -23,6 +23,8 @@ open Cmm
 open Reg
 open Mach
 
+let simd_regalloc_disabled () = not (Language_extension.is_enabled SIMD)
+
 let fp = Config.with_frame_pointers
 
 (* Which ABI to use *)
@@ -104,7 +106,7 @@ let register_class r =
   | Val | Int | Addr -> 0
   | Float -> 1
   | Vec128 ->
-    if not !simd_regalloc_support then
+    if simd_regalloc_disabled () then
     Misc.fatal_error "SIMD register allocation is not enabled.";
     1
 
@@ -115,7 +117,7 @@ let stack_slot_class typ =
   | Val | Addr | Int -> 0
   | Float -> 1
   | Vec128 ->
-    if not !simd_regalloc_support then
+    if simd_regalloc_disabled () then
     Misc.fatal_error "SIMD register allocation is not enabled.";
     2
 
@@ -124,7 +126,7 @@ let stack_class_tag c =
   | 0 -> "i"
   | 1 -> "f"
   | 2 ->
-    if not !simd_regalloc_support then
+    if simd_regalloc_disabled () then
     Misc.fatal_error "SIMD register allocation is not enabled.";
     "x"
   | c -> Misc.fatal_errorf "Unspecified stack slot class %d" c
@@ -141,7 +143,7 @@ let register_name ty r =
   | Float ->
     float_reg_name.(r - first_available_register.(1))
   | Vec128 ->
-    if not !simd_regalloc_support then
+    if simd_regalloc_disabled () then
     Misc.fatal_error "SIMD register allocation is not enabled.";
     float_reg_name.(r - first_available_register.(1))
 
@@ -164,13 +166,15 @@ let hard_float_reg =
 let hard_vec128_reg =
   let v = Array.make 16 Reg.dummy in
   for i = 0 to 15 do v.(i) <- Reg.at_location Vec128 (Reg (100 + i)) done;
-  fun () -> if !simd_regalloc_support then v
-            else Misc.fatal_error "SIMD register allocation is not enabled."
+  fun () -> if simd_regalloc_disabled ()
+            then Misc.fatal_error "SIMD register allocation is not enabled."
+            else v
 
 let all_phys_regs =
   let basic_regs = Array.append hard_int_reg hard_float_reg in
-  fun () -> if !simd_regalloc_support then Array.append basic_regs (hard_vec128_reg ())
-            else basic_regs
+  fun () -> if simd_regalloc_disabled ()
+            then basic_regs
+            else Array.append basic_regs (hard_vec128_reg ())
 
 let phys_reg ty n =
   match ty with
@@ -186,9 +190,9 @@ let rbp = phys_reg Int 12
 
 (* CSE needs to know that all versions of xmm15 are destroyed. *)
 let destroy_xmm15 () =
-  if !simd_regalloc_support
-  then [| phys_reg Float 115; phys_reg Vec128 115 |]
-  else [| phys_reg Float 115 |]
+  if simd_regalloc_disabled ()
+  then [| phys_reg Float 115 |]
+  else [| phys_reg Float 115; phys_reg Vec128 115 |]
 
 let destroyed_by_plt_stub =
   if not X86_proc.use_plt then [| |] else [| r10; r11 |]
@@ -200,7 +204,7 @@ let destroyed_by_plt_stub_set = Reg.set_of_array destroyed_by_plt_stub
 let stack_slot slot ty =
   (match ty with
    | Float | Int | Addr | Val -> ()
-   | Vec128 -> if not !simd_regalloc_support then
+   | Vec128 -> if simd_regalloc_disabled () then
      Misc.fatal_error "SIMD register allocation is not enabled.");
   Reg.at_location ty (Stack slot)
 
@@ -374,19 +378,19 @@ let destroyed_at_c_call_win64 =
     (Array.map (phys_reg Int) [|0;4;5;6;7;10;11|])
     (Array.sub hard_float_reg 0 6)
   in
-  fun () -> if !simd_regalloc_support
-  then Array.append basic_regs (Array.sub (hard_vec128_reg ()) 0 6)
-  else basic_regs
+  fun () -> if simd_regalloc_disabled ()
+            then basic_regs
+            else Array.append basic_regs (Array.sub (hard_vec128_reg ()) 0 6)
 
 let destroyed_at_c_call_unix =
   (* Unix: rbp, rbx, r12-r15 preserved *)
   let basic_regs = Array.append
     (Array.map (phys_reg Int) [|0;2;3;4;5;6;7;10;11|])
     hard_float_reg
   in
-  fun () -> if !simd_regalloc_support
-  then Array.append basic_regs (hard_vec128_reg ())
-  else basic_regs
+  fun () -> if simd_regalloc_disabled ()
+            then basic_regs
+            else Array.append basic_regs (hard_vec128_reg ())
 
 let destroyed_at_c_call =
   if win64 then destroyed_at_c_call_win64 else destroyed_at_c_call_unix

ocaml/typing/env.ml

@@ -2686,10 +2686,9 @@ let (initial_safe_string, initial_unsafe_string) =
 
 let add_language_extension_types env =
   lazy
-    ((* CR ccasinghino for mslater: Here, check the simd extension.  If it's on,
-        return [add_simd_extension_types (add_type ~check:false) env].
-        Otherwise, return env. *)
-      env)
+    (if Language_extension.is_enabled SIMD
+     then Predef.add_simd_extension_types (add_type ~check:false) env
+     else env)
 
 (* Some predefined types are part of language extensions, and we don't want to
    make them available in the initial environment if those extensions are not

ocaml/typing/predef.ml

@@ -264,7 +264,6 @@ let common_initial_env add_type add_extension empty_env =
   |> add_type ident_unit
        ~kind:(variant [cstr ident_void []] [| [| |] |])
        ~layout:(Layout.immediate ~why:Enumeration)
-  |> add_type ident_vec128
   (* Predefined exceptions - alphabetical order *)
   |> add_extension ident_assert_failure
        [newgenty (Ttuple[type_string; type_int; type_int])]
@@ -297,9 +296,7 @@ let build_initial_env add_type add_exception empty_env =
 
 let add_simd_extension_types add_type env =
   let add_type = mk_add_type add_type in
-  (* CR ccasinghino for mslater: Change the line below to [add_type ident_vec128
-     env]. *)
-  ignore add_type; env
+  add_type ident_vec128 env
 
 let builtin_values =
   List.map (fun id -> (Ident.name id, id)) all_predef_exns

ocaml/utils/language_extension.ml

@@ -50,6 +50,7 @@ let get_level_ops : type a. a t -> (module Extension_level with type t = a) =
   | Immutable_arrays -> (module Unit)
   | Module_strengthening -> (module Unit)
   | Layouts -> (module Maturity)
+  | SIMD -> (module Unit)
 
 type extn_pair = Exist_pair.t = Pair : 'a t * 'a -> extn_pair
 type exist = Exist.t = Pack : _ t -> exist
@@ -73,8 +74,9 @@ let equal_t (type a b) (a : a t) (b : b t) : (a, b) Misc.eq option = match a, b
   | Immutable_arrays, Immutable_arrays -> Some Refl
   | Module_strengthening, Module_strengthening -> Some Refl
   | Layouts, Layouts -> Some Refl
+  | SIMD, SIMD -> Some Refl
   | (Comprehensions | Local | Include_functor | Polymorphic_parameters |
-     Immutable_arrays | Module_strengthening | Layouts), _ -> None
+     Immutable_arrays | Module_strengthening | Layouts | SIMD), _ -> None
 
 let equal a b = Option.is_some (equal_t a b)
 

ocaml/utils/language_extension.mli

@@ -16,6 +16,7 @@ type 'a t = 'a Language_extension_kernel.t =
   | Immutable_arrays : unit t
   | Module_strengthening : unit t
   | Layouts : maturity t
+  | SIMD : unit t
 
 (** Existentially packed language extension *)
 module Exist : sig

ocaml/utils/language_extension_kernel.ml

@@ -9,6 +9,7 @@ type _ t =
   | Immutable_arrays : unit t
   | Module_strengthening : unit t
   | Layouts : maturity t
+  | SIMD : unit t
 
 type 'a language_extension_kernel = 'a t
 
@@ -23,6 +24,7 @@ module Exist = struct
     ; Pack Immutable_arrays
     ; Pack Module_strengthening
     ; Pack Layouts
+    ; Pack SIMD
     ]
 end
 
@@ -39,6 +41,7 @@ let to_string : type a. a t -> string = function
   | Immutable_arrays -> "immutable_arrays"
   | Module_strengthening -> "module_strengthening"
   | Layouts -> "layouts"
+  | SIMD -> "simd"
 
 (* converts full extension names, like "layouts_alpha" to a pair of
    an extension and its maturity. For extensions that don't take an
@@ -55,6 +58,7 @@ let pair_of_string extn_name : Exist_pair.t option =
   | "layouts" -> Some (Pair (Layouts, Stable))
   | "layouts_alpha" -> Some (Pair (Layouts, Alpha))
   | "layouts_beta" -> Some (Pair (Layouts, Beta))
+  | "simd" -> Some (Pair (SIMD, ()))
   | _ -> None
 
 let maturity_to_string = function
@@ -83,7 +87,8 @@ let is_erasable : type a. a t -> bool = function
   | Include_functor
   | Polymorphic_parameters
   | Immutable_arrays
-  | Module_strengthening ->
+  | Module_strengthening
+  | SIMD ->
       false
 
 (* See the mli. *)

ocaml/utils/language_extension_kernel.mli

@@ -18,6 +18,7 @@ type _ t =
   | Immutable_arrays : unit t
   | Module_strengthening : unit t
   | Layouts : maturity t
+  | SIMD : unit t
 
 module Exist : sig
   type 'a extn = 'a t

tests/simd/dune

@@ -9,14 +9,14 @@
  (name basic)
  (modules basic)
  (foreign_archives stubs)
- (ocamlopt_flags (:standard -fsimd)))
+ (ocamlopt_flags (:standard -extension simd)))
 
 (executable
  (name probes)
  (modules probes)
  (enabled_if (<> %{system} macosx))
  (foreign_archives stubs)
- (ocamlopt_flags (:standard -fsimd)))
+ (ocamlopt_flags (:standard -extension simd)))
 
 (rule
  (enabled_if (= %{context_name} "main"))

testsuite/tests/unboxed-primitive-args/test.ml

@@ -16,7 +16,7 @@ script = "${cc} -msse4.2 -c test_common.c -I ../../../../../../../../runtime"
 ***** script
 script = "${cc} -msse4.2 -c stubs.c -I ../../../../../../../../runtime"
 ****** ocamlopt.opt
-ocamlopt_flags = "-fsimd"
+ocamlopt_flags = "-extension simd"
 all_modules = "test_common.o stubs.o common.mli common.ml main.ml"
 ******* run
 ******** check-program-output