Merge remote-tracking branch 'origin/main' into tagged-small-ints

.depend

@@ -2554,7 +2554,6 @@ bytecomp/dll.cmx : \
 bytecomp/dll.cmi :
 bytecomp/emitcode.cmo : \
     lambda/translmod.cmi \
-    bytecomp/symtable.cmi \
     typing/primitive.cmi \
     bytecomp/opcodes.cmi \
     utils/misc.cmi \
@@ -2571,7 +2570,6 @@ bytecomp/emitcode.cmo : \
     bytecomp/emitcode.cmi
 bytecomp/emitcode.cmx : \
     lambda/translmod.cmx \
-    bytecomp/symtable.cmx \
     typing/primitive.cmx \
     bytecomp/opcodes.cmx \
     utils/misc.cmx \
@@ -4615,6 +4613,7 @@ file_formats/cms_format.cmo : \
     typing/shape.cmi \
     parsing/parsetree.cmi \
     utils/misc.cmi \
+    lambda/lambda.cmi \
     parsing/longident.cmi \
     parsing/location.cmi \
     parsing/lexer.cmi \
@@ -7733,23 +7732,27 @@ tools/dumpobj.cmo : \
     bytecomp/opcodes.cmi \
     utils/misc.cmi \
     parsing/location.cmi \
+    lambda/lambda.cmi \
     bytecomp/instruct.cmi \
     typing/ident.cmi \
     utils/config.cmi \
     file_formats/cmo_format.cmi \
     bytecomp/bytesections.cmi \
+    parsing/asttypes.cmi \
     tools/dumpobj.cmi
 tools/dumpobj.cmx : \
     bytecomp/symtable.cmx \
     tools/opnames.cmx \
     bytecomp/opcodes.cmx \
     utils/misc.cmx \
     parsing/location.cmx \
+    lambda/lambda.cmx \
     bytecomp/instruct.cmx \
     typing/ident.cmx \
     utils/config.cmx \
     file_formats/cmo_format.cmi \
     bytecomp/bytesections.cmx \
+    parsing/asttypes.cmi \
     tools/dumpobj.cmi
 tools/dumpobj.cmi :
 tools/eqparsetree.cmo : \

.github/workflows/selection.yml

@@ -0,0 +1,35 @@
+name: Selection changes reminder
+
+on:
+  pull_request_target:
+    types: [opened, synchronize, reopened]
+    paths:
+      - 'backend/selectgen.ml'
+      - 'backend/arm64/selection.ml'
+      - 'backend/amd64/selection.ml'
+
+jobs:
+  remind:
+    runs-on: ubuntu-latest
+    permissions:
+      pull-requests: write
+    steps:
+      - name: Create PR Comment
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+        run: |
+          REPO=${{ github.repository }}
+          PR_NUMBER=${{ github.event.pull_request.number }}
+          COMMENT="## Selection Change Check
+
+          This PR modifies the original selection pass (targeting Mach).
+          Please check whether the changes should also be applied to the
+          CFG variant of the pass."
+
+           # Check if comment already exists
+          if ! gh pr view $PR_NUMBER --json comments -q '.comments[].body' --repo $REPO | grep -q "Selection Change Check"; then
+            gh pr comment $PR_NUMBER --body "$COMMENT" --repo $REPO
+            echo "Comment added successfully."
+          else
+            echo "Comment already exists. Skipping."
+          fi

backend/cfg_selectgen.ml

@@ -161,16 +161,36 @@ class virtual selector_generic =
     (* Default instruction selection for operators *)
 
     method select_operation (op : Cmm.operation) (args : Cmm.expression list)
-        (_dbg : Debuginfo.t) ~label_after
+        (dbg : Debuginfo.t) ~label_after
         : basic_or_terminator * Cmm.expression list =
-      match op, args with
-      | Capply _, Cconst_symbol (func, _dbg) :: rem ->
-        Terminator (Call { op = Direct func; label_after }), rem
-      | Capply _, _ -> Terminator (Call { op = Indirect; label_after }), args
-      | Cextcall { func; builtin = true }, _ ->
+      let wrong_num_args n =
+        Misc.fatal_errorf
+          "Selection.select_operation: expected %d argument(s) for@ %s" n
+          (Printcmm.operation dbg op)
+      in
+      let[@inline] single_arg () =
+        match args with [arg] -> arg | [] | _ :: _ -> wrong_num_args 1
+      in
+      let[@inline] two_args () =
+        match args with
+        | [arg1; arg2] -> arg1, arg2
+        | [] | _ :: _ -> wrong_num_args 2
+      in
+      let[@inline] three_args () =
+        match args with
+        | [arg1; arg2; arg3] -> arg1, arg2, arg3
+        | [] | _ :: _ -> wrong_num_args 3
+      in
+      match[@ocaml.warning "+fragile-match"] op with
+      | Capply _ -> (
+        match[@ocaml.warning "-fragile-match"] args with
+        | Cconst_symbol (func, _dbg) :: rem ->
+          Terminator (Call { op = Direct func; label_after }), rem
+        | _ -> Terminator (Call { op = Indirect; label_after }), args)
+      | Cextcall { func; builtin = true } ->
         Misc.fatal_errorf
           "Selection.select_operation: builtin not recognized %s" func ()
-      | Cextcall { func; alloc; ty; ty_args; returns; builtin = false }, _ ->
+      | Cextcall { func; alloc; ty; ty_args; returns; builtin = false } ->
         let external_call =
           { Cfg.func_symbol = func;
             alloc;
@@ -183,91 +203,99 @@ class virtual selector_generic =
         then
           Terminator (Prim { op = External external_call; label_after }), args
         else Terminator (Call_no_return external_call), args
-      | Cload { memory_chunk; mutability; is_atomic }, [arg] ->
+      | Cload { memory_chunk; mutability; is_atomic } ->
+        let arg = single_arg () in
         let addressing_mode, eloc = self#select_addressing memory_chunk arg in
         let mutability = select_mutable_flag mutability in
         ( basic_op
             (Load { memory_chunk; addressing_mode; mutability; is_atomic }),
           [eloc] )
-      | Cstore (chunk, init), [arg1; arg2] -> (
+      | Cstore (chunk, init) -> (
+        let arg1, arg2 = two_args () in
         let addr, eloc = self#select_addressing chunk arg1 in
         let is_assign =
           match init with Initialization -> false | Assignment -> true
         in
-        match chunk with
+        match[@ocaml.warning "-fragile-match"] chunk with
         | Word_int | Word_val ->
           let op, newarg2 = self#select_store is_assign addr arg2 in
           basic_op op, [newarg2; eloc]
         | _ -> basic_op (Store (chunk, addr, is_assign)), [arg2; eloc]
         (* Inversion addr/datum in Istore *))
-      | Cdls_get, _ -> basic_op Dls_get, args
-      | Calloc mode, _ ->
-        basic_op (Alloc { bytes = 0; dbginfo = []; mode }), args
-      | Caddi, _ -> self#select_arith_comm Simple_operation.Iadd args
-      | Csubi, _ -> self#select_arith Simple_operation.Isub args
-      | Cmuli, _ -> self#select_arith_comm Simple_operation.Imul args
-      | Cmulhi { signed }, _ ->
+      | Cdls_get -> basic_op Dls_get, args
+      | Calloc mode -> basic_op (Alloc { bytes = 0; dbginfo = []; mode }), args
+      | Cpoll -> basic_op Poll, args
+      | Caddi -> self#select_arith_comm Simple_operation.Iadd args
+      | Csubi -> self#select_arith Simple_operation.Isub args
+      | Cmuli -> self#select_arith_comm Simple_operation.Imul args
+      | Cmulhi { signed } ->
         self#select_arith_comm (Simple_operation.Imulh { signed }) args
-      | Cdivi, _ -> basic_op (Intop Idiv), args
-      | Cmodi, _ -> basic_op (Intop Imod), args
-      | Cand, _ -> self#select_arith_comm Simple_operation.Iand args
-      | Cor, _ -> self#select_arith_comm Simple_operation.Ior args
-      | Cxor, _ -> self#select_arith_comm Simple_operation.Ixor args
-      | Clsl, _ -> self#select_arith Simple_operation.Ilsl args
-      | Clsr, _ -> self#select_arith Simple_operation.Ilsr args
-      | Casr, _ -> self#select_arith Simple_operation.Iasr args
-      | Cclz { arg_is_non_zero }, _ ->
+      | Cdivi -> basic_op (Intop Idiv), args
+      | Cmodi -> basic_op (Intop Imod), args
+      | Cand -> self#select_arith_comm Simple_operation.Iand args
+      | Cor -> self#select_arith_comm Simple_operation.Ior args
+      | Cxor -> self#select_arith_comm Simple_operation.Ixor args
+      | Clsl -> self#select_arith Simple_operation.Ilsl args
+      | Clsr -> self#select_arith Simple_operation.Ilsr args
+      | Casr -> self#select_arith Simple_operation.Iasr args
+      | Cclz { arg_is_non_zero } ->
         basic_op (Intop (Iclz { arg_is_non_zero })), args
-      | Cctz { arg_is_non_zero }, _ ->
+      | Cctz { arg_is_non_zero } ->
         basic_op (Intop (Ictz { arg_is_non_zero })), args
-      | Cpopcnt, _ -> basic_op (Intop Ipopcnt), args
-      | Ccmpi comp, _ ->
+      | Cpopcnt -> basic_op (Intop Ipopcnt), args
+      | Ccmpi comp ->
         self#select_arith_comp (Simple_operation.Isigned comp) args
-      | Caddv, _ -> self#select_arith_comm Simple_operation.Iadd args
-      | Cadda, _ -> self#select_arith_comm Simple_operation.Iadd args
-      | Ccmpa comp, _ ->
+      | Caddv -> self#select_arith_comm Simple_operation.Iadd args
+      | Cadda -> self#select_arith_comm Simple_operation.Iadd args
+      | Ccmpa comp ->
         self#select_arith_comp (Simple_operation.Iunsigned comp) args
-      | Ccmpf (w, comp), _ -> basic_op (Floatop (w, Icompf comp)), args
-      | Ccsel _, [cond; ifso; ifnot] ->
+      | Ccmpf (w, comp) -> basic_op (Floatop (w, Icompf comp)), args
+      | Ccsel _ ->
+        let cond, ifso, ifnot = three_args () in
         let cond, earg = self#select_condition cond in
         basic_op (Csel cond), [earg; ifso; ifnot]
-      | Cnegf w, _ -> basic_op (Floatop (w, Inegf)), args
-      | Cabsf w, _ -> basic_op (Floatop (w, Iabsf)), args
-      | Caddf w, _ -> basic_op (Floatop (w, Iaddf)), args
-      | Csubf w, _ -> basic_op (Floatop (w, Isubf)), args
-      | Cmulf w, _ -> basic_op (Floatop (w, Imulf)), args
-      | Cdivf w, _ -> basic_op (Floatop (w, Idivf)), args
-      | Creinterpret_cast cast, _ -> basic_op (Reinterpret_cast cast), args
-      | Cstatic_cast cast, _ -> basic_op (Static_cast cast), args
-      | Catomic { op = Fetch_and_add; size }, [src; dst] ->
-        let dst_size =
-          match size with
-          | Word | Sixtyfour -> Word_int
-          | Thirtytwo -> Thirtytwo_signed
-        in
-        let addr, eloc = self#select_addressing dst_size dst in
-        basic_op (Intop_atomic { op = Fetch_and_add; size; addr }), [src; eloc]
-      | Catomic { op = Compare_and_swap; size }, [compare_with; set_to; dst] ->
-        let dst_size =
-          match size with
-          | Word | Sixtyfour -> Word_int
-          | Thirtytwo -> Thirtytwo_signed
-        in
-        let addr, eloc = self#select_addressing dst_size dst in
-        ( basic_op (Intop_atomic { op = Compare_and_swap; size; addr }),
-          [compare_with; set_to; eloc] )
-      | Cprobe { name; handler_code_sym; enabled_at_init }, _ ->
+      | Cnegf w -> basic_op (Floatop (w, Inegf)), args
+      | Cabsf w -> basic_op (Floatop (w, Iabsf)), args
+      | Caddf w -> basic_op (Floatop (w, Iaddf)), args
+      | Csubf w -> basic_op (Floatop (w, Isubf)), args
+      | Cmulf w -> basic_op (Floatop (w, Imulf)), args
+      | Cdivf w -> basic_op (Floatop (w, Idivf)), args
+      | Creinterpret_cast cast -> basic_op (Reinterpret_cast cast), args
+      | Cstatic_cast cast -> basic_op (Static_cast cast), args
+      | Catomic { op; size } -> (
+        match op with
+        | Fetch_and_add ->
+          let src, dst = two_args () in
+          let dst_size =
+            match size with
+            | Word | Sixtyfour -> Word_int
+            | Thirtytwo -> Thirtytwo_signed
+          in
+          let addr, eloc = self#select_addressing dst_size dst in
+          basic_op (Intop_atomic { op = Fetch_and_add; size; addr }), [src; eloc]
+        | Compare_and_swap ->
+          let compare_with, set_to, dst = three_args () in
+          let dst_size =
+            match size with
+            | Word | Sixtyfour -> Word_int
+            | Thirtytwo -> Thirtytwo_signed
+          in
+          let addr, eloc = self#select_addressing dst_size dst in
+          ( basic_op (Intop_atomic { op = Compare_and_swap; size; addr }),
+            [compare_with; set_to; eloc] ))
+      | Cprobe { name; handler_code_sym; enabled_at_init } ->
         ( Terminator
             (Prim
                { op = Probe { name; handler_code_sym; enabled_at_init };
                  label_after
                }),
           args )
-      | Cprobe_is_enabled { name }, _ ->
-        basic_op (Probe_is_enabled { name }), []
-      | Cbeginregion, _ -> basic_op Begin_region, []
-      | Cendregion, _ -> basic_op End_region, args
-      | _ -> Misc.fatal_error "Selection.select_oper"
+      | Cprobe_is_enabled { name } -> basic_op (Probe_is_enabled { name }), []
+      | Cbeginregion -> basic_op Begin_region, []
+      | Cendregion -> basic_op End_region, args
+      | Cpackf32 | Copaque | Cbswap _ | Cprefetch _ | Craise _
+      | Ctuple_field (_, _) ->
+        Misc.fatal_error "Selection.select_oper"
 
     method private select_arith_comm (op : Simple_operation.integer_operation)
         (args : Cmm.expression list) : basic_or_terminator * Cmm.expression list

backend/cmm_builtins.ml

@@ -52,7 +52,7 @@ let if_operation_supported op ~f =
   match Proc.operation_supported op with true -> Some (f ()) | false -> None
 
 let if_operation_supported_bi bi op ~f =
-  if bi = Primitive.Pint64 && size_int = 4
+  if bi = Primitive.Unboxed_int64 && size_int = 4
   then None
   else if_operation_supported op ~f
 
@@ -72,13 +72,13 @@ let clz ~arg_is_non_zero bi arg dbg =
   let op = Cclz { arg_is_non_zero } in
   if_operation_supported_bi bi op ~f:(fun () ->
       let res = Cop (op, [make_unsigned_int bi arg dbg], dbg) in
-      if bi = Primitive.Pint32 && size_int = 8
+      if bi = Primitive.Unboxed_int32 && size_int = 8
       then Cop (Caddi, [res; Cconst_int (-32, dbg)], dbg)
       else res)
 
 let ctz ~arg_is_non_zero bi arg dbg =
   let arg = make_unsigned_int bi arg dbg in
-  if bi = Primitive.Pint32 && size_int = 8
+  if bi = Primitive.Unboxed_int32 && size_int = 8
   then
     (* regardless of the value of the argument [arg_is_non_zero], always set the
        corresponding field to [true], because we make it non-zero below by
@@ -439,17 +439,17 @@ let transl_builtin name args dbg typ_res =
         let arg = clear_sign_bit (one_arg name args) dbg in
         Cop (Caddi, [Cop (op, [arg], dbg); Cconst_int (-1, dbg)], dbg))
   | "caml_int64_clz_unboxed_to_untagged" ->
-    clz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg
+    clz ~arg_is_non_zero:false Unboxed_int64 (one_arg name args) dbg
   | "caml_int32_clz_unboxed_to_untagged" ->
-    clz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg
+    clz ~arg_is_non_zero:false Unboxed_int32 (one_arg name args) dbg
   | "caml_nativeint_clz_unboxed_to_untagged" ->
-    clz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg
+    clz ~arg_is_non_zero:false Unboxed_nativeint (one_arg name args) dbg
   | "caml_int64_clz_nonzero_unboxed_to_untagged" ->
-    clz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg
+    clz ~arg_is_non_zero:true Unboxed_int64 (one_arg name args) dbg
   | "caml_int32_clz_nonzero_unboxed_to_untagged" ->
-    clz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg
+    clz ~arg_is_non_zero:true Unboxed_int32 (one_arg name args) dbg
   | "caml_nativeint_clz_nonzero_unboxed_to_untagged" ->
-    clz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg
+    clz ~arg_is_non_zero:true Unboxed_nativeint (one_arg name args) dbg
   | "caml_int_popcnt_tagged_to_untagged" ->
     if_operation_supported Cpopcnt ~f:(fun () ->
         (* Having the argument tagged saves a shift, but there is one extra
@@ -462,11 +462,11 @@ let transl_builtin name args dbg typ_res =
         let arg = clear_sign_bit (one_arg name args) dbg in
         Cop (Cpopcnt, [arg], dbg))
   | "caml_int64_popcnt_unboxed_to_untagged" ->
-    popcnt Pint64 (one_arg name args) dbg
+    popcnt Unboxed_int64 (one_arg name args) dbg
   | "caml_int32_popcnt_unboxed_to_untagged" ->
-    popcnt Pint32 (one_arg name args) dbg
+    popcnt Unboxed_int32 (one_arg name args) dbg
   | "caml_nativeint_popcnt_unboxed_to_untagged" ->
-    popcnt Pnativeint (one_arg name args) dbg
+    popcnt Unboxed_nativeint (one_arg name args) dbg
   | "caml_int_ctz_untagged_to_untagged" ->
     (* Assuming a 64-bit x86-64 target:
 
@@ -496,19 +496,21 @@ let transl_builtin name args dbg typ_res =
         in
         Cop (op, [Cop (Cor, [one_arg name args; c], dbg)], dbg))
   | "caml_int32_ctz_unboxed_to_untagged" ->
-    ctz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg
+    ctz ~arg_is_non_zero:false Unboxed_int32 (one_arg name args) dbg
   | "caml_int64_ctz_unboxed_to_untagged" ->
-    ctz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg
+    ctz ~arg_is_non_zero:false Unboxed_int64 (one_arg name args) dbg
   | "caml_nativeint_ctz_unboxed_to_untagged" ->
-    ctz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg
+    ctz ~arg_is_non_zero:false Unboxed_nativeint (one_arg name args) dbg
   | "caml_int32_ctz_nonzero_unboxed_to_untagged" ->
-    ctz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg
+    ctz ~arg_is_non_zero:true Unboxed_int32 (one_arg name args) dbg
   | "caml_int64_ctz_nonzero_unboxed_to_untagged" ->
-    ctz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg
+    ctz ~arg_is_non_zero:true Unboxed_int64 (one_arg name args) dbg
   | "caml_nativeint_ctz_nonzero_unboxed_to_untagged" ->
-    ctz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg
-  | "caml_signed_int64_mulh_unboxed" -> mulhi ~signed:true Pint64 args dbg
-  | "caml_unsigned_int64_mulh_unboxed" -> mulhi ~signed:false Pint64 args dbg
+    ctz ~arg_is_non_zero:true Unboxed_nativeint (one_arg name args) dbg
+  | "caml_signed_int64_mulh_unboxed" ->
+    mulhi ~signed:true Unboxed_int64 args dbg
+  | "caml_unsigned_int64_mulh_unboxed" ->
+    mulhi ~signed:false Unboxed_int64 args dbg
   | "caml_int32_unsigned_to_int_trunc_unboxed_to_untagged" ->
     Some (zero_extend_32 dbg (one_arg name args))
   | "caml_csel_value" | "caml_csel_int_untagged" | "caml_csel_int64_unboxed"