Merge remote-tracking branch 'flambda-backend/main' into makearray_dy…

…namic

.github/workflows/build.yml

@@ -78,39 +78,57 @@ jobs:
             config: --enable-middle-end=flambda2 --disable-warn-error
             os: macos-latest
 
+          - name: flambda2_macos_arm64_irc
+            config: --enable-middle-end=flambda2 --disable-warn-error
+            os: macos-latest
+            build_ocamlparam: '_,w=-46,regalloc=irc'
+            ocamlparam: '_,w=-46,regalloc=irc'
+
+          - name: flambda2_macos_arm64_ls
+            config: --enable-middle-end=flambda2 --disable-warn-error
+            os: macos-latest
+            build_ocamlparam: '_,w=-46,regalloc=ls'
+            ocamlparam: '_,w=-46,regalloc=ls'
+
+          - name: flambda2_macos_arm64_gi
+            config: --enable-middle-end=flambda2 --disable-warn-error
+            os: macos-latest
+            build_ocamlparam: '_,w=-46,regalloc=gi'
+            ocamlparam: '_,w=-46,regalloc=gi'
+
           - name: irc
             config: --enable-middle-end=flambda2
             os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
-            ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
+            build_ocamlparam: '_,w=-46,regalloc=irc'
+            ocamlparam: '_,w=-46,regalloc=irc'
             check_arch: true
 
           - name: irc_polling
             config: --enable-middle-end=flambda2 --enable-poll-insertion
             os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
-            ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
+            build_ocamlparam: '_,w=-46,regalloc=irc'
+            ocamlparam: '_,w=-46,regalloc=irc'
             check_arch: true
 
           - name: irc_frame_pointers
             config: --enable-middle-end=flambda2 --enable-frame-pointers
             os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
-            ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
+            build_ocamlparam: '_,w=-46,regalloc=irc'
+            ocamlparam: '_,w=-46,regalloc=irc'
             check_arch: true
 
           - name: ls
             config: --enable-middle-end=flambda2
             os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1'
-            ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1'
+            build_ocamlparam: '_,w=-46,regalloc=ls'
+            ocamlparam: '_,w=-46,regalloc=ls'
             check_arch: true
 
           - name: gi
             config: --enable-middle-end=flambda2
             os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1'
-            ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1'
+            build_ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1'
+            ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1'
             check_arch: true
 
           - name: cfg-selection
@@ -120,6 +138,13 @@ jobs:
             ocamlparam: '_,w=-46,regalloc=cfg,cfg-cse-optimize=1,cfg-selection=1,cfg-zero-alloc-checker=1'
             check_arch: true
 
+          - name: vectorizer
+            config: --enable-middle-end=flambda2
+            os: ubuntu-latest
+            build_ocamlparam: '_,w=-46,regalloc=cfg,vectorize=1'
+            ocamlparam: '_,w=-46,regalloc=cfg,vectorize=1'
+            check_arch: true
+
     env:
       J: "3"
       run_testsuite: "true"
@@ -229,11 +254,20 @@ jobs:
           --with-dune=$GITHUB_WORKSPACE/ocaml-414/_install/bin/dune \
           ${{ matrix.config }}
 
+    - name: Setup for saving core files (not for macOS at the moment)
+      if: matrix.os != 'macos-latest'
+      run: |
+        sudo mkdir /cores
+        sudo chmod 777 /cores
+        # Core filenames will be of the form executable.pid.timestamp:
+        sudo bash -c 'echo "/cores/%e.%p.%t" > /proc/sys/kernel/core_pattern'
+
     - name: Build, install and test Flambda backend
       working-directory: flambda_backend
       run: |
         if [ $run_testsuite = true ]; then target=ci; else target=compiler; fi
         export PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH
+        ulimit -c unlimited
         make $target \
           || (if [ $expected_fail = true ]; then exit 0; else exit 1; fi);
       env:
@@ -247,6 +281,25 @@ jobs:
       if: matrix.check_arch == true
       run: |
         PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH make check_all_arches
+
+    - uses: actions/upload-artifact@v3
+      if: ${{ failure() }} && matrix.os != 'macos-latest'
+      with:
+        name: cores
+        path: /cores
+
+    - uses: actions/upload-artifact@v3
+      if: ${{ failure() }} && matrix.os != 'macos-latest'
+      with:
+        name: _build
+        path: $GITHUB_WORKSPACE/_build
+
+    - uses: actions/upload-artifact@v3
+      if: ${{ failure() }} && matrix.os != 'macos-latest'
+      with:
+        name: _runtest
+        path: $GITHUB_WORKSPACE/_runtest
+
 concurrency:
   group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }}
   cancel-in-progress: true

.github/workflows/ocamlformat.yml

@@ -21,7 +21,7 @@ jobs:
         path: 'flambda_backend'
 
     - name: Setup OCaml ${{ matrix.ocaml-compiler }}
-      uses: ocaml/setup-ocaml@v2
+      uses: ocaml/setup-ocaml@v3
       with:
         ocaml-compiler: ${{ matrix.ocaml-compiler }}
 

Makefile

@@ -87,7 +87,7 @@ promote:
 
 .PHONY: fmt
 fmt:
-	ocamlformat -i $$(find . \( -name "*.ml" -or -name "*.mli" \))
+	find . \( -name "*.ml" -or -name "*.mli" \) | xargs -P $$(nproc 2>/dev/null || echo 1) -n 20 ocamlformat -i
 
 .PHONY: check-fmt
 check-fmt:

backend/amd64/emit.mlp

@@ -2316,7 +2316,7 @@ let emit_probe_notes0 () =
         Misc.fatal_errorf "Cannot create probe: illegal argument: %a"
           Printreg.reg arg
     in
-    Printf.sprintf "%d@%s" (Reg.size_of_contents_in_bytes arg) arg_name
+    Printf.sprintf "%d@%s" (Select_utils.size_component arg.Reg.typ) arg_name
   in
   let describe_one_probe p =
     let probe_name, enabled_at_init =

backend/amd64/simd_selection.ml

@@ -491,7 +491,7 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
           ~res_count operation ]
   in
   let create_const_vec consts =
-    let highs, lows = Misc.Stdlib.List.split_at (length / 2) consts in
+    let lows, highs = Misc.Stdlib.List.split_at (length / 2) consts in
     let pack_int64 nums =
       let mask =
         Int64.shift_right_logical Int64.minus_one (64 - width_in_bits)
@@ -589,13 +589,14 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
       let sse_op =
         match width_type with
         | W128 -> assert false
-        | W64 -> assert false
-        | W32 -> SRA_i32
-        | W16 -> SRA_i16
-        | W8 -> assert false
+        | W64 -> None
+        | W32 -> Some SRA_i32
+        | W16 -> Some SRA_i16
+        | W8 -> None
       in
-      Operation.Specific (Isimd (SSE2 sse_op))
-      |> make_default ~arg_count ~res_count
+      Option.bind sse_op (fun sse_op ->
+          Operation.Specific (Isimd (SSE2 sse_op))
+          |> make_default ~arg_count ~res_count)
     | Icomp (Isigned intcomp) -> (
       match intcomp with
       | Ceq ->
@@ -702,9 +703,9 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
       then (
         assert (arg_count = 1 && res_count = 1);
         const_instruction.results.(0)
-          <- Vectorize_utils.Vectorized_instruction.New 0;
+          <- Vectorize_utils.Vectorized_instruction.New_Vec128 0;
         intop_instruction.arguments.(1)
-          <- Vectorize_utils.Vectorized_instruction.New 0;
+          <- Vectorize_utils.Vectorized_instruction.New_Vec128 0;
         Some [const_instruction; intop_instruction])
       else None
     | _ -> None)
@@ -775,8 +776,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
           (* reg + displ *)
           Some
             [ make_move (Argument 0) (Result 0);
-              make_const (New 0) displs;
-              make_binary_operation (Result 0) (New 0) (Result 0) add ]
+              make_const (New_Vec128 0) displs;
+              make_binary_operation (Result 0) (New_Vec128 0) (Result 0) add ]
         | None -> None)
       | Iindexed2 _ -> (
         match add_op with
@@ -787,8 +788,8 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
           Some
             [ make_move (Argument 0) (Result 0);
               make_binary_operation (Result 0) (Argument 1) (Result 0) add;
-              make_const (New 0) displs;
-              make_binary_operation (Result 0) (New 0) (Result 0) add ]
+              make_const (New_Vec128 0) displs;
+              make_binary_operation (Result 0) (New_Vec128 0) (Result 0) add ]
         | None -> None)
       | Iscaled _ -> (
         match add_op, mul_op with
@@ -799,10 +800,10 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
           (* reg * scale + displ *)
           Some
             [ make_move (Argument 0) (Result 0);
-              make_const (New 0) scales;
-              make_binary_operation (Result 0) (New 0) (Result 0) mul;
-              make_const (New 1) displs;
-              make_binary_operation (Result 0) (New 1) (Result 0) add ]
+              make_const (New_Vec128 0) scales;
+              make_binary_operation (Result 0) (New_Vec128 0) (Result 0) mul;
+              make_const (New_Vec128 1) displs;
+              make_binary_operation (Result 0) (New_Vec128 1) (Result 0) add ]
         | _ -> None)
       | Iindexed2scaled _ -> (
         match add_op, mul_op with
@@ -813,11 +814,11 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
           (* reg + reg * scale + displ *)
           Some
             [ make_move (Argument 1) (Result 0);
-              make_const (New 0) scales;
-              make_binary_operation (Result 0) (New 0) (Result 0) mul;
+              make_const (New_Vec128 0) scales;
+              make_binary_operation (Result 0) (New_Vec128 0) (Result 0) mul;
               make_binary_operation (Result 0) (Argument 0) (Result 0) add;
-              make_const (New 1) displs;
-              make_binary_operation (Result 0) (New 1) (Result 0) add ]
+              make_const (New_Vec128 1) displs;
+              make_binary_operation (Result 0) (New_Vec128 1) (Result 0) add ]
         | _ -> None)
       | Ibased _ -> None)
     | Isextend32 -> (

backend/cfg/vectorize.ml

@@ -2725,10 +2725,32 @@ end = struct
           t1.new_positions t2.new_positions
     }
 
+  (** address registers and vectorizable registers of [t] and [t'] are compatible, i.e.,
+      register [r] used as an address argument in [t] is not replaced by a vectorizable
+      argument in [t'] and vice versa. *)
+  let register_compatible t t' deps =
+    let sub t1 t2 =
+      Instruction.Id.Map.for_all
+        (fun _key g1 ->
+          let scalar_instructions = Group.scalar_instructions g1 in
+          Group.for_all_non_vectorizable_args g1 ~f:(fun ~arg_i ->
+              List.for_all
+                (fun i ->
+                  match
+                    Dependencies.get_direct_dependency_of_arg deps
+                      (Instruction.id i) ~arg_i
+                  with
+                  | None -> true
+                  | Some dep -> not (contains_id t2 dep))
+                scalar_instructions))
+        t1.groups
+    in
+    sub t t' && sub t' t
+
   (** [compatible t t'] returns true if for every group [g] in [t],
       and [g'] in [t'],  [g] and [g'] are equal or have disjoint sets
       of scalar instructions. *)
-  let compatible t t' =
+  let instruction_compatible t t' =
     if Instruction.Id.Set.disjoint t.all_scalar_instructions
          t'.all_scalar_instructions
     then true
@@ -2747,15 +2769,15 @@ end = struct
               (* disjoint groups: if the key is not in t2, then all insts are
                  not in t2. *)
               List.for_all
-                (fun i ->
-                  not
-                    (Instruction.Id.Set.mem (Instruction.id i)
-                       t2.all_scalar_instructions))
+                (fun i -> not (contains t2 i))
                 (Group.scalar_instructions g1))
           t1.groups
       in
       sub t t' && sub t' t
 
+  let compatible t t' deps =
+    instruction_compatible t t' && register_compatible t t' deps
+
   let select_and_join trees block deps =
     match trees with
     | [] -> None
@@ -2767,7 +2789,7 @@ end = struct
         match trees with
         | [] -> acc
         | hd :: tl ->
-          if compatible hd acc
+          if compatible hd acc deps
           then
             let new_acc = join hd acc in
             if compare_cost new_acc acc < 0
@@ -2866,7 +2888,7 @@ let add_vector_instructions_for_group reg_map state group ~before:cell
     let get_register
         (simd_reg : Vectorize_utils.Vectorized_instruction.register) =
       match simd_reg with
-      | New n -> get_new_reg n
+      | New_Vec128 n -> get_new_reg n
       | Argument n ->
         let original_reg = (Instruction.arguments key_instruction).(n) in
         Substitution.get_reg_exn reg_map original_reg

backend/cmm_helpers.ml

@@ -802,9 +802,10 @@ let box_float32 dbg mode exp =
 
 let unbox_float32 dbg =
   map_tail ~kind:Any (function
-    | Cop (Calloc _, [Cconst_natint (hdr, _); _ops; c], _)
-      when Nativeint.equal hdr boxedfloat32_header
-           || Nativeint.equal hdr boxedfloat32_local_header ->
+    | Cop (Calloc _, [Cconst_natint (hdr, _); Cconst_symbol (sym, _); c], _)
+      when (Nativeint.equal hdr boxedfloat32_header
+           || Nativeint.equal hdr boxedfloat32_local_header)
+           && String.equal sym.sym_name caml_float32_ops ->
       c
     | Cconst_symbol (s, _dbg) as cmm -> (
       match Cmmgen_state.structured_constant_of_sym s.sym_name with

backend/printreg.ml

@@ -63,6 +63,8 @@ let regs' ?(print_reg = reg) ppf v =
 
 let regs ppf v = regs' ppf v
 
+let reglist ppf l = Format.pp_print_list ~pp_sep:pp_print_space reg ppf l
+
 let regset ppf s =
   let first = ref true in
   Set.iter

backend/printreg.mli

@@ -37,6 +37,8 @@ val regs : Format.formatter -> Reg.t array -> unit
 
 val regset : Format.formatter -> Reg.Set.t -> unit
 
+val reglist : Format.formatter -> Reg.t list -> unit
+
 val regsetaddr' :
   ?print_reg:(Format.formatter -> Reg.t -> unit) ->
   Format.formatter ->

backend/reg.ml

@@ -193,18 +193,6 @@ let is_reg t =
   | Reg _ -> true
   | _ -> false
 
-let size_of_contents_in_bytes t =
-  match t.typ with
-  | Vec128 -> Arch.size_vec128
-  | Float -> Arch.size_float
-  | Float32 ->
-    assert (Arch.size_float = 8);
-    Arch.size_float / 2
-  | Addr ->
-    assert (Arch.size_addr = Arch.size_int);
-    Arch.size_addr
-  | Int | Val -> Arch.size_int
-
 let reset() =
   (* When reset() is called for the first time, the current stamp reflects
      all hard pseudo-registers that have been allocated by Proc, so

backend/reg.mli

@@ -102,8 +102,6 @@ val name : t -> string
 val is_reg : t -> bool
 val is_stack :  t -> bool
 
-val size_of_contents_in_bytes : t -> int
-
 module Set: Set.S with type elt = t
 module Map: Map.S with type key = t
 module Tbl: Hashtbl.S with type key = t