Code review fixes

bytecomp/bytegen.ml

@@ -741,7 +741,7 @@ 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 { src_mutability = _; array_kind = _; dst_array_set_kind } ->
+  | 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."

lambda/lambda.ml

@@ -198,7 +198,6 @@ type primitive =
   | Pduparray of array_kind * mutable_flag
   | Parrayblit of {
       src_mutability : mutable_flag;
-      array_kind : array_kind;
       dst_array_set_kind : array_set_kind;
     }
   | Parraylength of array_kind
@@ -2455,6 +2454,20 @@ let array_set_kind mode = function
   | Pgcscannableproductarray kinds -> Pgcscannableproductarray_set (mode, kinds)
   | Pgcignorableproductarray kinds -> Pgcignorableproductarray_set kinds
 
+let array_kind_of_array_set_kind (kind : array_set_kind) : array_kind =
+  match kind with
+  | Pintarray_set -> Pintarray
+  | Punboxedfloatarray_set uf -> Punboxedfloatarray uf
+  | Punboxedintarray_set ui -> Punboxedintarray ui
+  | Punboxedvectorarray_set uv -> Punboxedvectorarray uv
+  | Pgcscannableproductarray_set (_, scannables) ->
+    Pgcscannableproductarray scannables
+  | Pgcignorableproductarray_set ignorables ->
+    Pgcignorableproductarray ignorables
+  | Pgenarray_set _ -> Pgenarray
+  | Paddrarray_set _ -> Paddrarray
+  | Pfloatarray_set -> Pfloatarray
+
 let array_ref_kind_of_array_set_kind (kind : array_set_kind) mode
       : array_ref_kind =
   match kind with

lambda/lambda.mli

@@ -192,14 +192,17 @@ type primitive =
       array being *produced* by the duplication. *)
   | Parrayblit of {
       src_mutability : mutable_flag;
-      array_kind : array_kind;
       dst_array_set_kind : array_set_kind;
     }
   (** For [Parrayblit], we record the [array_set_kind] of the destination
       array. We check that the source array has the same shape, but do not
       need to know anything about its locality. We do however request the
       mutability of the source array. *)
   | Parraylength of array_kind
+  (** For [Pnormal_access], the array kind and array ref kinds must be in
+      sync.  This is not currently checked. *)
+  (* CR mshinwell: consider changing these constructors so that for normal
+     accesses only the array_ref_kind is provided? *)
   | Parrayrefu of array_ref_kind * array_kind * array_index_kind * mutable_flag
                   * array_access_reinterp
   (** The [array_kind], not the [array_ref_kind], determines the stride for
@@ -1230,6 +1233,8 @@ val array_set_kind : modify_mode -> array_kind -> array_set_kind
 val array_ref_kind_of_array_set_kind
   : array_set_kind -> locality_mode -> array_ref_kind
 
+val array_kind_of_array_set_kind : array_set_kind -> array_kind
+
 (* Returns true if the given lambda can allocate on the local stack *)
 val may_allocate_in_region : lambda -> bool
 

lambda/printlambda.ml

@@ -689,10 +689,9 @@ let primitive ppf = function
   | Pduparray (k, Immutable) -> fprintf ppf "duparray_imm[%s]" (array_kind k)
   | Pduparray (k, Immutable_unique) ->
       fprintf ppf "duparray_unique[%s]" (array_kind k)
-  | Parrayblit { src_mutability; array_kind = ak; dst_array_set_kind } ->
-      fprintf ppf "arrayblit[%s %s -> %a]"
+  | Parrayblit { src_mutability; dst_array_set_kind } ->
+      fprintf ppf "arrayblit[%s -> %a]"
         (array_mut src_mutability)
-        (array_kind ak)
         array_set_kind dst_array_set_kind
   | Parrayrefu (rk, ak, idx, mut, reinterp) ->
       fprintf ppf "%s.unsafe_get[%a indexed by %a, array kind %s%s]"

lambda/translprim.ml

@@ -586,13 +586,11 @@ let lookup_primitive loc ~poly_mode ~poly_sort pos p =
     | "%arrayblit" ->
       Primitive (Parrayblit {
         src_mutability = Mutable;
-        array_kind = Pgenarray;
         dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ())
       }, 5);
     | "%arrayblit_src_immut" ->
       Primitive (Parrayblit {
         src_mutability = Immutable;
-        array_kind = Pgenarray;
         dst_array_set_kind = gen_array_set_kind (get_third_arg_mode ())
       }, 5);
     | "%array_element_size_in_bytes" ->
@@ -1409,8 +1407,7 @@ let specialize_primitive env loc ty ~has_constant_constructor prim =
     Misc.fatal_errorf
       "Wrong arity for Pmakearray_dynamic (arity=%d, args length %d)"
       arity (List.length args)
-  | Primitive (Parrayblit { src_mutability; array_kind; dst_array_set_kind },
-      arity),
+  | Primitive (Parrayblit { src_mutability; dst_array_set_kind }, arity),
     _p1 :: _ :: p2 :: _ ->
     let loc = to_location loc in
     (* We only use the kind of one of two input arrays here. If you've bound the
@@ -1422,12 +1419,10 @@ let specialize_primitive env loc ty ~has_constant_constructor prim =
     let new_dst_array_set_kind =
       glb_array_set_type loc dst_array_set_kind new_array_kind
     in
-    if array_kind = new_array_kind
-       && dst_array_set_kind = new_dst_array_set_kind
+    if dst_array_set_kind = new_dst_array_set_kind
     then None
     else Some (Primitive (Parrayblit {
       src_mutability;
-      array_kind = new_array_kind;
       dst_array_set_kind = new_dst_array_set_kind }, arity))
   | Primitive (Parray_element_size_in_bytes _, arity), p1 :: _ -> (
       let array_kind =

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1482,7 +1482,14 @@ let check_valid_reinterpret_set_kinds (array_kind : L.array_kind)
   | Preinterp_access -> (
     check_valid_reinterpret_array_kind array_kind fail;
     match array_set_kind with
-    | Pgenarray_set _ | Paddrarray_set _ | Pintarray_set | Pfloatarray_set
+    | Pgenarray_set _ | Paddrarray_set _ ->
+      (* For the moment, GC-scannable values are only allowed to be written and
+         read from arrays using reinterpret operations if the kind is immediate.
+         In other words, no squirreling away of GC-able pointers into (e.g.)
+         integer arrays, and no conjuring-up of "valid" OCaml values from such
+         arrays. *)
+      fail ()
+    | Pintarray_set | Pfloatarray_set
     | Punboxedfloatarray_set Unboxed_float64
     | Punboxedintarray_set Unboxed_int64
     | Punboxedintarray_set Unboxed_nativeint
@@ -1508,7 +1515,10 @@ let check_valid_reinterpret_ref_kinds (array_kind : L.array_kind)
   | Preinterp_access -> (
     check_valid_reinterpret_array_kind array_kind fail;
     match array_ref_kind with
-    | Pgenarray_ref _ | Paddrarray_ref | Pintarray_ref | Pfloatarray_ref _
+    | Pgenarray_ref _ | Paddrarray_ref ->
+      (* See comment above in the "set" case. *)
+      fail ()
+    | Pintarray_ref | Pfloatarray_ref _
     | Punboxedfloatarray_ref Unboxed_float64
     | Punboxedintarray_ref Unboxed_int64
     | Punboxedintarray_ref Unboxed_nativeint
@@ -2238,6 +2248,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
            ~current_region) ]
   | ( Parrayrefs (array_ref_kind, array_kind, index_kind, mut, reinterp),
       [[array]; [index]] ) ->
+    check_valid_reinterpret_ref_kinds array_kind array_ref_kind reinterp dbg;
     reinterpret_not_supported dbg reinterp;
     let array_length_kind = convert_array_kind_for_length array_kind in
     [ check_array_access ~dbg ~array array_length_kind ~index ~index_kind
@@ -2255,6 +2266,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
            ~new_values) ]
   | ( Parraysets (array_set_kind, array_kind, index_kind, reinterp),
       [[array]; [index]; new_values] ) ->
+    check_valid_reinterpret_set_kinds array_kind array_set_kind reinterp dbg;
     reinterpret_not_supported dbg reinterp;
     let array_length_kind = convert_array_kind_for_length array_kind in
     [ check_array_access ~dbg ~array array_length_kind ~index ~index_kind
@@ -2689,7 +2701,7 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
             _,
             _,
             _,
-            _)
+            _ )
       | Pcompare_ints | Pcompare_floats _ | Pcompare_bints _
       | Patomic_exchange _ | Patomic_set _ | Patomic_fetch_add | Patomic_add
       | Patomic_sub | Patomic_land | Patomic_lor | Patomic_lxor | Ppoke _ ),

middle_end/flambda2/from_lambda/lambda_to_lambda_transforms.ml

@@ -465,15 +465,16 @@ let makearray_dynamic env (lambda_array_kind : L.array_kind)
     makearray_dynamic_non_scannable_unboxed_product env lambda_array_kind mode
       ~length ~init loc
 
-let arrayblit env ~(src_mutability : L.mutable_flag) array_kind
-    ~dst_array_set_kind args loc =
+let arrayblit env ~(src_mutability : L.mutable_flag) ~dst_array_set_kind args
+    loc =
   let src_array_ref_kind =
     (* We don't expect any allocation (e.g. occurring from the reading of a
        [float array]) to persist after simplification. We use [alloc_local] just
        in case that simplification doesn't happen for some reason (this seems
        unlikely). *)
     L.array_ref_kind_of_array_set_kind dst_array_set_kind L.alloc_local
   in
+  let array_kind = L.array_kind_of_array_set_kind dst_array_set_kind in
   match args with
   | [src_expr; src_start_pos_expr; dst_expr; dst_start_pos_expr; length_expr] ->
     (* Care: the [args] are arbitrary Lambda expressions, so need to be
@@ -708,11 +709,7 @@ let transform_primitive env (prim : L.primitive) args loc =
   match prim with
   | Pmakearray_dynamic (lambda_array_kind, mode, has_init) ->
     makearray_dynamic env lambda_array_kind mode has_init args loc
-  | Parrayblit
-      { src_mutability;
-        array_kind;
-        dst_array_set_kind;
-      } ->
-    arrayblit env ~src_mutability array_kind ~dst_array_set_kind args loc
+  | Parrayblit { src_mutability; dst_array_set_kind } ->
+    arrayblit env ~src_mutability ~dst_array_set_kind args loc
   | _ -> env, transform_primitive0 env prim args loc
   [@@ocaml.warning "-fragile-match"]

middle_end/flambda2/to_cmm/to_cmm_primitive.ml

@@ -325,8 +325,12 @@ let array_load ~dbg (array_kind : P.Array_kind.t)
       "Cannot use array load kind [Values] on naked number/vector arrays:@ %a"
       Debuginfo.print_compact dbg
   | Naked_int64s, Immediates ->
-    C.unboxed_int64_or_nativeint_array_ref ~has_custom_ops:true arr
-      ~array_index:index dbg
+    (* To match the other reinterpret primitives and for safety, we set the
+       bottom bit (without any shift). *)
+    C.or_int
+      (C.unboxed_int64_or_nativeint_array_ref ~has_custom_ops:true arr
+         ~array_index:index dbg)
+      (C.int ~dbg 0x1) dbg
   | Naked_int64s, Naked_floats ->
     let index =
       (* The layouts of these arrays differ: the int64# array has an extra field