Use the new directives in Arm

.github/workflows/build.yml

@@ -205,7 +205,7 @@ jobs:
       id: cache
       with:
         path: ${{ github.workspace }}/ocaml-414/_install
-        key: ${{ matrix.os }}-cache-ocaml-414-dune-3152-menhir-20231231
+        key: ${{ matrix.os }}-cache-ocaml-414-patched-dune-3152-menhir-20231231
 
     - name: Checkout OCaml 4.14
       uses: actions/checkout@master
@@ -219,6 +219,7 @@ jobs:
       if: steps.cache.outputs.cache-hit != 'true'
       working-directory: ocaml-414
       run: |
+        patch -p1 < $GITHUB_WORKSPACE/flambda_backend/arm64-issue-debug-upstream.patch
         ./configure --prefix=$GITHUB_WORKSPACE/ocaml-414/_install
         make -j $J world.opt
         make install

arm64-issue-debug-upstream.patch

@@ -0,0 +1,67 @@
+diff --git a/driver/compenv.ml b/driver/compenv.ml
+index 8b1c4e5559..3e7de2533d 100644
+--- a/driver/compenv.ml
++++ b/driver/compenv.ml
+@@ -489,6 +489,7 @@ let read_one_param ppf position name v =
+ let read_OCAMLPARAM ppf position =
+   try
+     let s = Sys.getenv "OCAMLPARAM" in
++    Warnings.parsed_ocamlparam := s;
+     if s <> "" then
+       let (before, after) =
+         try
+diff --git a/utils/warnings.ml b/utils/warnings.ml
+index 895ef2be07..dc7a23b6c9 100644
+--- a/utils/warnings.ml
++++ b/utils/warnings.ml
+@@ -459,7 +459,10 @@ let name_to_number =
+
+ (* Must be the max number returned by the [number] function. *)
+
+-let letter = function
++let parsed_ocamlparam = ref "<not-set>"
++
++(* CR-soon xclerc for xclerc: remove the `for_debug` parameter... *)
++let letter for_debug = function
+   | 'a' ->
+      let rec loop i = if i = 0 then [] else i :: loop (i - 1) in
+      loop last_warning_number
+@@ -488,7 +491,9 @@ let letter = function
+   | 'x' -> [14; 15; 16; 17; 18; 19; 20; 21; 22; 23; 24; 30]
+   | 'y' -> [26]
+   | 'z' -> [27]
+-  | _ -> assert false
++  | chr ->
++     let ocamlparam_from_env = match Sys.getenv_opt "OCAMLPARAM" with None -> "-" | Some  value -> value in
++     Misc.fatal_errorf "Warnings.letter %C (for_debug=%S, ocamlparam_from_env=%S ocamlparam_from_compenv=%S)" chr for_debug ocamlparam_from_env !parsed_ocamlparam
+ ;;
+
+ type state =
+@@ -745,7 +750,7 @@ let parse_opt error active errflag s =
+           | None -> if c = lc then Clear else Set
+           | Some m -> m
+         in
+-        List.iter (action modifier) (letter lc)
++        List.iter (action modifier) (letter s lc)
+     | Num(n1,n2,modifier) ->
+         for n = n1 to Int.min n2 last_warning_number do action modifier n done
+   in
+@@ -1131,7 +1136,7 @@ let help_warnings () =
+   print_endline "  A all warnings";
+   for i = Char.code 'b' to Char.code 'z' do
+     let c = Char.chr i in
+-    match letter c with
++    match letter "<help-warnings>" c with
+     | [] -> ()
+     | [n] ->
+         Printf.printf "  %c Alias for warning %i.\n" (Char.uppercase_ascii c) n
+diff --git a/utils/warnings.mli b/utils/warnings.mli
+index 3d9ea91f38..70d17a9181 100644
+--- a/utils/warnings.mli
++++ b/utils/warnings.mli
+@@ -161,3 +161,5 @@ type description =
+     description : string; }
+
+ val descriptions : description list
++
++val parsed_ocamlparam : string ref

asmcomp/asmgen.ml

@@ -156,8 +156,15 @@ let write_ir prefix =
 
 let should_emit () = not (should_stop_after Compiler_pass.Linearization)
 
-let should_use_linscan fun_codegen_options =
-  !use_linscan || List.mem Cmm.Use_linscan_regalloc fun_codegen_options
+(* note: `should_use_linscan` relies on the state of the `Reg` module, as the
+   list of temporaries is retrieved to be compared to the threshold. *)
+let should_use_linscan fd =
+  !use_linscan
+  || List.mem Cmm.Use_linscan_regalloc fd.fun_codegen_options
+  || List.compare_length_with
+       (Reg.all_relocatable_regs ())
+       !Flambda_backend_flags.regalloc_linscan_threshold
+     > 0
 
 let if_emit_do f x = if should_emit () then f x else ()
 
@@ -288,15 +295,12 @@ type register_allocator =
   | IRC
   | LS
 
-let default_allocator = IRC
-
 let register_allocator fd : register_allocator =
   match String.lowercase_ascii !Flambda_backend_flags.regalloc with
-  | "cfg" -> if should_use_linscan fd.fun_codegen_options then LS else IRC
+  | "" | "cfg" -> if should_use_linscan fd then LS else IRC
   | "gi" -> GI
   | "irc" -> IRC
   | "ls" -> LS
-  | "" -> default_allocator
   | other -> Misc.fatal_errorf "unknown register allocator (%S)" other
 
 let available_regs ~stack_slots ~f x =
@@ -376,7 +380,6 @@ let compile_cfg ppf_dump ~funcnames fd_cmm cfg_with_layout =
 
 let compile_fundecl ~ppf_dump ~funcnames fd_cmm =
   let module Cfg_selection = Cfg_selectgen.Make (Cfg_selection) in
-  Proc.init ();
   Reg.clear_relocatable_regs ();
   fd_cmm
   ++ Profile.record ~accumulate:true "cmm_invariants" (cmm_invariants ppf_dump)

backend/.ocamlformat-enable

@@ -1,14 +1,19 @@
 ; CR-soon gyorsh: format all files under arm64/amd64
 amd64/cfg_selection.ml
 amd64/emit.ml
+amd64/reg_class.ml
+amd64/reg_class.mli
 amd64/selection.ml
 amd64/selection_utils.ml
 amd64/simd*.ml
 amd64/stack_check.ml
 amd64/stack_class.ml
 amd64/vectorize_specific.ml
+amd64/regalloc_stack_operands.ml
 arm64/cfg_selection.ml
 arm64/emit.ml
+arm64/reg_class.ml
+arm64/reg_class.mli
 arm64/selection.ml
 arm64/selection_utils.ml
 arm64/simd*.ml
@@ -62,6 +67,9 @@ printoperation.ml
 printoperation.mli
 printreg.ml
 printreg.mli
+reg_class.mli
+reg_class_utils.ml
+reg_class_utils.mli
 proc.mli
 regalloc/**/*.ml
 regalloc/**/*.mli

backend/amd64/CSE.ml

@@ -38,6 +38,7 @@ let class_of_operation (op : Operation.t)
     | Ibswap _ -> Use_default
     | Irdtsc | Irdpmc
     | Ilfence | Isfence | Imfence -> Class Op_other
+    | Ipackf32 -> Class Op_pure
     | Isimd op ->
       Class (of_simd_class (Simd.class_of_operation op))
     | Isimd_mem (op,_addr) ->

backend/amd64/arch.ml

@@ -179,6 +179,7 @@ type specific_operation =
   | Isfence                            (* store fence *)
   | Imfence                            (* memory fence *)
   | Ipause                             (* hint for spin-wait loops *)
+  | Ipackf32                           (* UNPCKLPS on registers; see Cpackf32 *)
   | Isimd of Simd.operation            (* SIMD instruction set operations *)
   | Isimd_mem of Simd.Mem.operation * addressing_mode
                                        (* SIMD instruction set operations
@@ -301,6 +302,8 @@ let print_specific_operation printreg op ppf arg =
       fprintf ppf "mfence"
   | Irdpmc ->
       fprintf ppf "rdpmc %a" printreg arg.(0)
+  | Ipackf32 ->
+      fprintf ppf "packf32 %a %a" printreg arg.(0) printreg arg.(1)
   | Isimd simd ->
       Simd.print_operation printreg simd ppf arg
   | Isimd_mem (simd, addr) ->
@@ -330,14 +333,16 @@ let operation_is_pure = function
   | Ilfence | Isfence | Imfence
   | Istore_int (_, _, _) | Ioffset_loc (_, _)
   | Icldemote _ | Iprefetch _ -> false
-  | Isimd op -> Simd.is_pure op
-  | Isimd_mem (op, _addr) -> Simd.Mem.is_pure op
+  | Ipackf32 -> true
+  | Isimd op -> Simd.is_pure_operation op
+  | Isimd_mem (op, _addr) -> Simd.Mem.is_pure_operation op
 
 (* Keep in sync with [Vectorize_specific] *)
 let operation_allocates = function
   | Ilea _ | Ibswap _ | Isextend32 | Izextend32
   | Ifloatarithmem _
-  | Irdtsc | Irdpmc | Ipause | Isimd _ | Isimd_mem _
+  | Irdtsc | Irdpmc | Ipause | Ipackf32
+  | Isimd _ | Isimd_mem _
   | Ilfence | Isfence | Imfence
   | Istore_int (_, _, _) | Ioffset_loc (_, _)
   | Icldemote _ | Iprefetch _ -> false
@@ -419,7 +424,10 @@ let equal_specific_operation left right =
     true
   | Imfence, Imfence ->
     true
-  | Ipause, Ipause -> true
+  | Ipause, Ipause ->
+    true
+  | Ipackf32, Ipackf32 ->
+    true
   | Icldemote x, Icldemote x' -> equal_addressing_mode x x'
   | Iprefetch { is_write = left_is_write; locality = left_locality; addr = left_addr; },
     Iprefetch { is_write = right_is_write; locality = right_locality; addr = right_addr; } ->
@@ -432,7 +440,7 @@ let equal_specific_operation left right =
     Simd.Mem.equal_operation l r && equal_addressing_mode al ar
   | (Ilea _ | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ |
      Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence |
-     Ipause | Isimd _ | Isimd_mem _ | Icldemote _ | Iprefetch _), _ ->
+     Ipause | Ipackf32 | Isimd _ | Isimd_mem _ | Icldemote _ | Iprefetch _), _ ->
     false
 
 (* addressing mode functions *)
@@ -528,7 +536,10 @@ let isomorphic_specific_operation op1 op2 =
     true
   | Imfence, Imfence ->
     true
-  | Ipause, Ipause -> true
+  | Ipause, Ipause ->
+    true
+  | Ipackf32, Ipackf32 ->
+    true
   | Icldemote x, Icldemote x' -> equal_addressing_mode_without_displ x x'
   | Iprefetch { is_write = left_is_write; locality = left_locality; addr = left_addr; },
     Iprefetch { is_write = right_is_write; locality = right_locality; addr = right_addr; } ->
@@ -541,5 +552,5 @@ let isomorphic_specific_operation op1 op2 =
     Simd.Mem.equal_operation l r && equal_addressing_mode_without_displ al ar
   | (Ilea _ | Istore_int _ | Ioffset_loc _ | Ifloatarithmem _ | Ibswap _ |
      Isextend32 | Izextend32 | Irdtsc | Irdpmc | Ilfence | Isfence | Imfence |
-     Ipause | Isimd _ | Isimd_mem _ | Icldemote _ | Iprefetch _), _ ->
+     Ipause | Ipackf32 | Isimd _ | Isimd_mem _ | Icldemote _ | Iprefetch _), _ ->
     false

backend/amd64/arch.mli

@@ -86,6 +86,7 @@ type specific_operation =
   | Isfence                            (* store fence *)
   | Imfence                            (* memory fence *)
   | Ipause                             (* hint for spin-wait loops *)
+  | Ipackf32                           (* UNPCKLPS on registers; see Cpackf32 *)
   | Isimd of Simd.operation            (* SIMD instruction set operations *)
   | Isimd_mem of Simd.Mem.operation * addressing_mode
                                        (* SIMD instruction set operations

backend/amd64/cfg_selection.ml

@@ -131,7 +131,8 @@ let pseudoregs_for_operation op arg res =
   match (op : Operation.t) with
   (* Two-address binary operations: arg.(0) and res.(0) must be the same *)
   | Intop (Iadd | Isub | Imul | Iand | Ior | Ixor)
-  | Floatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf)) ->
+  | Floatop ((Float32 | Float64), (Iaddf | Isubf | Imulf | Idivf))
+  | Specific Ipackf32 ->
     [| res.(0); arg.(1) |], res
   | Intop_atomic { op = Compare_set; size = _; addr = _ } ->
     (* first arg must be rax *)
@@ -192,14 +193,9 @@ let pseudoregs_for_operation op arg res =
        edx (high) and eax (low). Make it simple and force the argument in rcx,
        and rax and rdx clobbered *)
     [| rcx |], res
-  | Specific (Isimd op) ->
-    Simd_selection.pseudoregs_for_operation
-      (Simd_proc.register_behavior op)
-      arg res
+  | Specific (Isimd op) -> Simd_selection.pseudoregs_for_operation op arg res
   | Specific (Isimd_mem (op, _addr)) ->
-    Simd_selection.pseudoregs_for_operation
-      (Simd_proc.Mem.register_behavior op)
-      arg res
+    Simd_selection.pseudoregs_for_mem_operation op arg res
   | Csel _ ->
     (* last arg must be the same as res.(0) *)
     let len = Array.length arg in
@@ -351,7 +347,7 @@ let select_operation
        a float stack slot, the resulting UNPCKLPS instruction would enforce the
        validity of loading it as a 128-bit memory location, even though it only
        loads 64 bits. *)
-    Rewritten (specific (Isimd (SSE Interleave_low_32_regs)), args)
+    Rewritten (specific Ipackf32, args)
   (* Special cases overriding C implementations (regardless of [@@builtin]). *)
   | Cextcall { func = "sqrt" as func; _ }
   (* x86 intrinsics ([@@builtin]) *)