For testing only (more checks)

.github/workflows/build.yml

@@ -18,58 +18,58 @@ jobs:
         include:
           - name: flambda2_runtime5
             config: --enable-middle-end=flambda2 --enable-runtime5
-            os: ubuntu-latest
+            os: ubuntu-22.04
 
           - name: flambda2_dev
             config: --enable-middle-end=flambda2 --enable-dev
-            os: ubuntu-latest
+            os: ubuntu-22.04
 
           - name: flambda2_dev_runtime5
             config: --enable-middle-end=flambda2 --enable-dev --enable-runtime5
-            os: ubuntu-latest
+            os: ubuntu-22.04
 
           - name: flambda2_debug_runtime5
             config: --enable-middle-end=flambda2 --enable-runtime5
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             use_runtime: d
             ocamlrunparam: "v=0,V=1"
 
           - name: flambda2_debug_runtime
             config: --enable-middle-end=flambda2
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             use_runtime: d
             ocamlrunparam: "v=0,V=1"
 
           - name: flambda2_o3
             config: --enable-middle-end=flambda2
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             ocamlparam: '_,O3=1'
 
           - name: flambda2_o3_heap
             config: --enable-middle-end=flambda2 --disable-stack-allocation
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             ocamlparam: '_,O3=1'
 
           - name: flambda2_o3_advanced_meet_frame_pointers_runtime5_polling
             config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5 --enable-poll-insertion --enable-flambda-invariants
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced,flambda2-expert-cont-lifting-budget=200'
 
           - name: flambda2_o3_advanced_meet_frame_pointers_runtime5_debug
             config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-runtime5
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             use_runtime: d
             ocamlparam: '_,O3=1,flambda2-meet-algorithm=advanced,flambda2-expert-cont-lifting-budget=200'
 
           - name: flambda2_frame_pointers_oclassic_polling
             config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion --enable-flambda-invariants
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: ''
             ocamlparam: '_,Oclassic=1'
             disable_testcases: 'testsuite/tests/typing-local/regression_cmm_unboxing.ml testsuite/tests/int64-unboxing/test.ml'
@@ -98,53 +98,46 @@ jobs:
 
           - name: irc
             config: --enable-middle-end=flambda2
-            os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=irc'
-            ocamlparam: '_,w=-46,regalloc=irc'
+            os: ubuntu-22.04
+            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'
             check_arch: true
 
           - name: irc_polling
             config: --enable-middle-end=flambda2 --enable-poll-insertion
-            os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=irc'
-            ocamlparam: '_,w=-46,regalloc=irc'
+            os: ubuntu-22.04
+            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'
             check_arch: true
 
           - name: irc_frame_pointers
             config: --enable-middle-end=flambda2 --enable-frame-pointers
-            os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=irc'
-            ocamlparam: '_,w=-46,regalloc=irc'
+            os: ubuntu-22.04
+            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'
             check_arch: true
 
           - name: ls
             config: --enable-middle-end=flambda2
-            os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=ls'
-            ocamlparam: '_,w=-46,regalloc=ls'
+            os: ubuntu-22.04
+            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'
             check_arch: true
 
           - name: gi
             config: --enable-middle-end=flambda2
-            os: ubuntu-latest
-            build_ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1'
-            ocamlparam: '_,w=-46,regalloc=gi,cfg-cse-optimize=1'
+            os: ubuntu-22.04
+            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'
             check_arch: true
 
           - name: cfg-selection
             config: --enable-middle-end=flambda2
-            os: ubuntu-latest
+            os: ubuntu-22.04
             build_ocamlparam: '_,w=-46,regalloc=cfg,cfg-cse-optimize=1,cfg-selection=1,cfg-zero-alloc-checker=1'
             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"
@@ -157,9 +150,13 @@ jobs:
         path: 'flambda_backend'
 
     - name: Install AFL (for Linux workers)
-      if: matrix.os == 'ubuntu-latest'
+      if: matrix.os == 'ubuntu-22.04'
       run: sudo apt-get install afl++
 
+    - name: gdb
+      if: matrix.os == 'ubuntu-22.04'
+      run: sudo apt-get install gdb
+
     - name: Install AFL (for macOS workers)
       # The "afl-fuzz" package is deprecated (2023-10) and can no longer be installed
       if: matrix.os == 'macos-latest'
@@ -268,8 +265,9 @@ jobs:
         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);
+        echo "GITHUB_WORKSPACE is: $GITHUB_WORKSPACE"
+        make $target
+        ls -lR $GITHUB_WORKSPACE
       env:
         BUILD_OCAMLPARAM: ${{ matrix.build_ocamlparam }}
         OCAMLPARAM: ${{ matrix.ocamlparam }}
@@ -288,17 +286,21 @@ jobs:
         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 }}/flambda_backend/_runtest
+#        retention-days: 5
+#        include-hidden-files: true
 
     - uses: actions/upload-artifact@v3
-      if: ${{ failure() }} && matrix.os != 'macos-latest'
+      if: always()
       with:
-        name: _runtest
-        path: $GITHUB_WORKSPACE/_runtest
+        name: typing-layouts-arrays_${{ matrix.name }}
+        path: ${{ github.workspace }}/flambda_backend/_runtest/testsuite/tests/typing-layouts-arrays/
+
+#        path: ${{ github.workspace }}/flambda_backend/_runtest/testsuite/tests/typing-layouts-arrays/_ocamltest/tests/typing-layouts-arrays/test_ignorable_product_array_with_uninit_2/ocamlopt.opt/test_ignorable_product_array_with_uninit_2.opt
 
 concurrency:
   group: ${{ github.workflow }}-${{ github.head_ref || github.run_id }}

.github/workflows/ocamlformat.yml

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

Makefile

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

backend/amd64/simd_selection.ml

@@ -589,14 +589,13 @@ let vectorize_operation (width_type : Vectorize_utils.Width_in_bits.t)
       let sse_op =
         match width_type with
         | W128 -> assert false
-        | W64 -> None
-        | W32 -> Some SRA_i32
-        | W16 -> Some SRA_i16
-        | W8 -> None
+        | W64 -> assert false
+        | W32 -> SRA_i32
+        | W16 -> SRA_i16
+        | W8 -> assert false
       in
-      Option.bind sse_op (fun sse_op ->
-          Operation.Specific (Isimd (SSE2 sse_op))
-          |> make_default ~arg_count ~res_count)
+      Operation.Specific (Isimd (SSE2 sse_op))
+      |> make_default ~arg_count ~res_count
     | Icomp (Isigned intcomp) -> (
       match intcomp with
       | Ceq ->

backend/cfg/vectorize.ml

@@ -2725,32 +2725,10 @@ 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 instruction_compatible t t' =
+  let compatible t t' =
     if Instruction.Id.Set.disjoint t.all_scalar_instructions
          t'.all_scalar_instructions
     then true
@@ -2769,15 +2747,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 (contains t2 i))
+                (fun i ->
+                  not
+                    (Instruction.Id.Set.mem (Instruction.id i)
+                       t2.all_scalar_instructions))
                 (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
@@ -2789,7 +2767,7 @@ end = struct
         match trees with
         | [] -> acc
         | hd :: tl ->
-          if compatible hd acc deps
+          if compatible hd acc
           then
             let new_acc = join hd acc in
             if compare_cost new_acc acc < 0

backend/cmm_helpers.ml

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

bytecomp/bytegen.ml

@@ -685,7 +685,10 @@ let comp_primitive stack_info p sz args =
         "Preinterpret_unboxed_int64_as_tagged_int63 can only be used on 64-bit \
          targets";
     Kccall("caml_reinterpret_unboxed_int64_as_tagged_int63", 1)
-  | Pmakearray_dynamic(kind, locality) ->
+  | Pmakearray_dynamic(kind, locality, With_initializer) ->
+    if List.compare_length_with args 2 <> 0 then
+      fatal_error "Bytegen.comp_primitive: Pmakearray_dynamic takes two \
+        arguments for [With_initializer]";
     (* CR layouts v4.0: This is "wrong" for unboxed types. It should construct
        blocks that can't be marshalled. We've decided to ignore that problem in
        the short term, as it's unlikely to cause issues - see the internal arrays
@@ -701,15 +704,18 @@ let comp_primitive stack_info p sz args =
     | Alloc_heap -> Kccall("caml_make_vect", 2)
     | Alloc_local -> Kccall("caml_make_local_vect", 2)
     end
-  | Parrayblit(kind) ->
-    begin match kind with
+  | Parrayblit { src_mutability = _; dst_array_set_kind } ->
+    begin match dst_array_set_kind with
     | Punboxedvectorarray_set _ ->
       fatal_error "SIMD is not supported in bytecode mode."
     | Pgenarray_set _ | Pintarray_set | Paddrarray_set _
     | Punboxedintarray_set _ | Pfloatarray_set | Punboxedfloatarray_set _
     | Pgcscannableproductarray_set _ | Pgcignorableproductarray_set _ -> ()
     end;
     Kccall("caml_array_blit", 5)
+  | Pmakearray_dynamic(_, _, Uninitialized) ->
+    Misc.fatal_error "Pmakearray_dynamic Uninitialized should have been \
+      translated to Pmakearray_dynamic Initialized earlier on"
   (* The cases below are handled in [comp_expr] before the [comp_primitive] call
      (in the order in which they appear below),
      so they should never be reached in this function. *)
@@ -1011,6 +1017,54 @@ and comp_expr stack_info env exp sz cont =
           (Kreperformterm(sz + nargs) :: discard_dead_code cont)
       else
         fatal_error "Reperform used in non-tail position"
+  | Lprim (Pmakearray_dynamic (kind, locality, Uninitialized), [len], loc) ->
+      (* Use a dummy initializer to implement the "uninitialized" primitive *)
+      let init =
+        match kind with
+        | Pgenarray | Paddrarray | Pintarray | Pfloatarray
+        | Pgcscannableproductarray _ ->
+            Misc.fatal_errorf "Array kind %s should have been ruled out by \
+                the frontend for %%makearray_dynamic_uninit"
+              (Printlambda.array_kind kind)
+        | Punboxedfloatarray Unboxed_float32 ->
+            Lconst (Const_base (Const_float32 "0.0"))
+        | Punboxedfloatarray Unboxed_float64 ->
+            Lconst (Const_base (Const_float "0.0"))
+        | Punboxedintarray Unboxed_int32 ->
+            Lconst (Const_base (Const_int32 0l))
+        | Punboxedintarray Unboxed_int64 ->
+            Lconst (Const_base (Const_int64 0L))
+        | Punboxedintarray Unboxed_nativeint ->
+            Lconst (Const_base (Const_nativeint 0n))
+        | Punboxedvectorarray _ ->
+            fatal_error "SIMD is not supported in bytecode mode."
+        | Pgcignorableproductarray ignorables ->
+            let rec convert_ignorable
+                  (ign : Lambda.ignorable_product_element_kind) =
+              match ign with
+              | Pint_ignorable -> Lconst (Const_base (Const_int 0))
+              | Punboxedfloat_ignorable Unboxed_float32 ->
+                Lconst (Const_base (Const_float32 "0.0"))
+              | Punboxedfloat_ignorable Unboxed_float64 ->
+                Lconst (Const_base (Const_float "0.0"))
+              | Punboxedint_ignorable Unboxed_int32 ->
+                Lconst (Const_base (Const_int32 0l))
+              | Punboxedint_ignorable Unboxed_int64 ->
+                Lconst (Const_base (Const_int64 0L))
+              | Punboxedint_ignorable Unboxed_nativeint ->
+                Lconst (Const_base (Const_nativeint 0n))
+              | Pproduct_ignorable ignorables ->
+                  let fields = List.map convert_ignorable ignorables in
+                  Lprim (Pmakeblock (0, Immutable, None, alloc_heap), fields,
+                    loc)
+            in
+            convert_ignorable (Pproduct_ignorable ignorables)
+      in
+      comp_expr stack_info env
+        (Lprim (Pmakearray_dynamic (kind, locality, With_initializer),
+          [len; init], loc)) sz cont
+  | Lprim (Pmakearray_dynamic (_, _, Uninitialized), _, _loc) ->
+      Misc.fatal_error "Pmakearray_dynamic takes one arg when [Uninitialized]"
   | Lprim (Pduparray (kind, mutability),
            [Lprim (Pmakearray (kind',_,m),args,_)], loc) ->
       assert (kind = kind');