Code review

Author: mshinwell

backend/cmm_helpers.ml

@@ -64,6 +64,7 @@ let mk_load_atomic memory_chunk =
 
 let floatarray_tag dbg = Cconst_int (Obj.double_array_tag, dbg)
 
+(* CR mshinwell: update to use NOT_MARKABLE terminology *)
 let block_header tag sz =
   Nativeint.add
     (Nativeint.shift_left (Nativeint.of_int sz) 10)
@@ -118,6 +119,8 @@ let boxedint64_local_header =
 
 let boxedintnat_local_header = local_block_header Obj.custom_tag 2
 
+let black_custom_header ~size = black_block_header Obj.custom_tag size
+
 let custom_header ~size = block_header Obj.custom_tag size
 
 let custom_local_header ~size = local_block_header Obj.custom_tag size
@@ -924,7 +927,6 @@ let unboxed_int32_array_length arr dbg =
           sub_int (get_size arr dbg) (int ~dbg 1) dbg,
           Clet
             ( VP.create custom_ops_var,
-              (* CR gbury/mshinwell: check the atomicity of this load *)
               Cop (mk_load_immut Word_int, [arr], dbg),
               Cifthenelse
                 ( Cop
@@ -1024,6 +1026,36 @@ let addr_array_initialize arr ofs newval dbg =
       [array_indexing log2_size_addr arr ofs dbg; newval],
       dbg )
 
+(* low_32 x is a value which agrees with x on at least the low 32 bits *)
+let rec low_32 dbg = function
+  (* Ignore sign and zero extensions, which do not affect the low bits *)
+  | Cop (Casr, [Cop (Clsl, [x; Cconst_int (32, _)], _); Cconst_int (32, _)], _)
+  | Cop (Cand, [x; Cconst_natint (0xFFFFFFFFn, _)], _) ->
+    low_32 dbg x
+  | Clet (id, e, body) -> Clet (id, e, low_32 dbg body)
+  | x -> x
+
+(* sign_extend_32 sign-extends values from 32 bits to the word size. *)
+let sign_extend_32 dbg e =
+  match low_32 dbg e with
+  | Cop
+      ( Cload
+          { memory_chunk = Thirtytwo_unsigned | Thirtytwo_signed;
+            mutability;
+            is_atomic
+          },
+        args,
+        dbg ) ->
+    Cop
+      ( Cload { memory_chunk = Thirtytwo_signed; mutability; is_atomic },
+        args,
+        dbg )
+  | e ->
+    Cop
+      ( Casr,
+        [Cop (Clsl, [e; Cconst_int (32, dbg)], dbg); Cconst_int (32, dbg)],
+        dbg )
+
 let unboxed_int32_array_ref arr index dbg =
   bind "arr" arr (fun arr ->
       bind "index" index (fun index ->
@@ -1034,11 +1066,12 @@ let unboxed_int32_array_ref arr index dbg =
             add_int index (int ~dbg 2) dbg
           in
           let log2_size_addr = 2 in
-          Cop
-            (* CR gbury/mshinwell: check the atomicity of the load *)
-            ( mk_load_mut Thirtytwo_signed,
-              [array_indexing log2_size_addr arr index dbg],
-              dbg )))
+          (* N.B. The resulting value must be sign extended! *)
+          sign_extend_32 dbg
+            (Cop
+               ( mk_load_mut Thirtytwo_signed,
+                 [array_indexing log2_size_addr arr index dbg],
+                 dbg ))))
 
 let unboxed_int64_or_nativeint_array_ref arr index dbg =
   bind "arr" arr (fun arr ->
@@ -1416,15 +1449,6 @@ let check_64_bit_target func =
     Misc.fatal_errorf
       "Cmm helpers function %s can only be used on 64-bit targets" func
 
-(* low_32 x is a value which agrees with x on at least the low 32 bits *)
-let rec low_32 dbg = function
-  (* Ignore sign and zero extensions, which do not affect the low bits *)
-  | Cop (Casr, [Cop (Clsl, [x; Cconst_int (32, _)], _); Cconst_int (32, _)], _)
-  | Cop (Cand, [x; Cconst_natint (0xFFFFFFFFn, _)], _) ->
-    low_32 dbg x
-  | Clet (id, e, body) -> Clet (id, e, low_32 dbg body)
-  | x -> x
-
 (* Like [low_32] but for 63-bit integers held in 64-bit registers. *)
 (* CR gbury: Why not use Cmm.map_tail here ? It seems designed for that kind of
    thing (and covers more cases than just Clet). *)
@@ -1438,27 +1462,6 @@ let rec low_63 dbg e =
   | Clet (id, x, body) -> Clet (id, x, low_63 dbg body)
   | _ -> e
 
-(* sign_extend_32 sign-extends values from 32 bits to the word size. *)
-let sign_extend_32 dbg e =
-  match low_32 dbg e with
-  | Cop
-      ( Cload
-          { memory_chunk = Thirtytwo_unsigned | Thirtytwo_signed;
-            mutability;
-            is_atomic
-          },
-        args,
-        dbg ) ->
-    Cop
-      ( Cload { memory_chunk = Thirtytwo_signed; mutability; is_atomic },
-        args,
-        dbg )
-  | e ->
-    Cop
-      ( Casr,
-        [Cop (Clsl, [e; Cconst_int (32, dbg)], dbg); Cconst_int (32, dbg)],
-        dbg )
-
 (* CR-someday mshinwell/gbury: sign_extend_63 then tag_int should simplify to
    just tag_int. Similarly, untag_int then sign_extend_63 should simplify to
    untag_int. *)
@@ -2860,13 +2863,13 @@ let arraylength kind arg dbg =
     in
     Cop (Cor, [len; Cconst_int (1, dbg)], dbg)
   | Paddrarray | Pintarray ->
-    (* Note we only support 64 bit targets now, so this is ok for
-       Punboxedfloatarray *)
     Cop (Cor, [addr_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
-  | Punboxedintarray Pint64 | Punboxedintarray Pnativeint ->
-    unboxed_int64_or_nativeint_array_length arg dbg
   | Pfloatarray | Punboxedfloatarray ->
+    (* Note: we only support 64 bit targets now, so this is ok for
+       Punboxedfloatarray *)
     Cop (Cor, [float_array_length_shifted hdr dbg; Cconst_int (1, dbg)], dbg)
+  | Punboxedintarray Pint64 | Punboxedintarray Pnativeint ->
+    unboxed_int64_or_nativeint_array_length arg dbg
   | Punboxedintarray Pint32 -> unboxed_int32_array_length arg dbg
 
 (* CR-soon gyorsh: effects and coeffects for primitives are set conservatively
@@ -3708,32 +3711,39 @@ let atomic_compare_and_set ~dbg atomic ~old_value ~new_value =
       [atomic; old_value; new_value],
       dbg )
 
+type even_or_odd =
+  | Even
+  | Odd
+
 let make_unboxed_int32_array_payload dbg unboxed_int32_list =
+  (* CR mshinwell/gbury: potential big-endian implementations:
+   *
+   *  let i =
+   *    if big_endian
+   *    then Cop (Clsl, [a; Cconst_int (32, dbg)], dbg)
+   *    else a
+   *  in
+   *   ...
+   *  let i =
+   *    if big_endian
+   *    then Cop (Cor, [Cop (Clsl, [a; Cconst_int (32, dbg)], dbg); b], dbg)
+   *    else Cop (Cor, [a; Cop (Clsl, [b; Cconst_int (32, dbg)], dbg)], dbg)
+   *  in
+   *)
+  if Sys.big_endian
+  then
+    Misc.fatal_error "Big-endian platforms not yet supported for unboxed arrays";
   let rec aux acc = function
-    | [] -> true, List.rev acc
-    | a :: [] ->
-      let i =
-        (* CR gbury: check/test that this is correct *)
-        if big_endian
-        then Cop (Clsl, [a; Cconst_int (32, dbg)], dbg)
-        else sign_extend_32 dbg a
-      in
-      false, List.rev (i :: acc)
+    | [] -> Even, List.rev acc
+    | a :: [] -> Odd, List.rev (a :: acc)
     | a :: b :: r ->
-      let i =
-        (* CR gbury: check/test that this is correct *)
-        if big_endian
-        then Cop (Cor, [Cop (Clsl, [a; Cconst_int (32, dbg)], dbg); b], dbg)
-        else Cop (Cor, [a; Cop (Clsl, [b; Cconst_int (32, dbg)], dbg)], dbg)
-      in
+      let i = Cop (Cor, [a; Cop (Clsl, [b; Cconst_int (32, dbg)], dbg)], dbg) in
       aux (i :: acc) r
   in
   aux [] unboxed_int32_list
 
 let allocate_unboxed_int32_array ~elements (mode : Lambda.alloc_mode) dbg =
-  let even_num_of_elts, payload =
-    make_unboxed_int32_array_payload dbg elements
-  in
+  let num_elts, payload = make_unboxed_int32_array_payload dbg elements in
   let header =
     let size = 1 (* custom_ops field *) + List.length payload in
     match mode with
@@ -3742,10 +3752,10 @@ let allocate_unboxed_int32_array ~elements (mode : Lambda.alloc_mode) dbg =
   in
   let custom_ops =
     (* For odd-length unboxed int32 arrays there are 32 bits spare at the end of
-       the block *)
-    if even_num_of_elts
-    then custom_ops_unboxed_int32_even_array
-    else custom_ops_unboxed_int32_odd_array
+       the block, which are never read. *)
+    match num_elts with
+    | Even -> custom_ops_unboxed_int32_even_array
+    | Odd -> custom_ops_unboxed_int32_odd_array
   in
   Cop (Calloc mode, Cconst_natint (header, dbg) :: custom_ops :: payload, dbg)
 

backend/cmm_helpers.mli

@@ -42,7 +42,7 @@ val black_closure_header : int -> nativeint
 (** Infix header at the given offset *)
 val infix_header : int -> nativeint
 
-val custom_header : size:int -> nativeint
+val black_custom_header : size:int -> nativeint
 
 (** Closure info for a closure of given arity and distance to environment *)
 val closure_info : arity:arity -> startenv:int -> is_last:bool -> nativeint
@@ -918,19 +918,20 @@ val unboxed_int32_array_ref :
   expression -> expression -> Debuginfo.t -> expression
 
 (** Read from an unboxed int64 or unboxed nativeint array (without bounds
-     check). *)
+    check). *)
 val unboxed_int64_or_nativeint_array_ref :
   expression -> expression -> Debuginfo.t -> expression
 
-(** Update an unboxed int64 or unboxed nativeint array. *)
+(** Update an unboxed int32 array (without bounds check). *)
 val unboxed_int32_array_set :
   expression ->
   index:expression ->
   new_value:expression ->
   Debuginfo.t ->
   expression
 
-(** Update an unboxed int64 or unboxed nativeint array. *)
+(** Update an unboxed int64 or unboxed nativeint array (without bounds
+    check). *)
 val unboxed_int64_or_nativeint_array_set :
   expression ->
   index:expression ->

middle_end/flambda2/flambda2.ml

@@ -103,6 +103,11 @@ let lambda_to_cmm ~ppf_dump:ppf ~prefixname ~filename:_ ~keep_symbol_tables
      [Name_occurrences]. *)
   if Sys.word_size <> 64
   then Misc.fatal_error "Flambda 2 can only run on 64-bit hosts at present";
+  (* At least one place in the Cmm translation code (for unboxed arrays) cannot
+     cope with big-endian systems, and it seems unlikely any such systems will
+     have to be supported in the future anyway. *)
+  if Arch.big_endian
+  then Misc.fatal_error "Flambda2 only supports little-endian hosts";
   (* When the float array optimisation is enabled, the length of an array needs
      to be computed differently according to the array kind, in the case where
      the width of a float is not equal to the machine word width (at present,

middle_end/flambda2/kinds/flambda_kind.ml

@@ -334,7 +334,7 @@ module With_subkind = struct
       | Value_array, Value_array
       | Generic_array, Generic_array
       | Unboxed_int32_array, Unboxed_int32_array
-      | Unboxed_int64_array, Unboxed_int32_array
+      | Unboxed_int64_array, Unboxed_int64_array
       | Unboxed_nativeint_array, Unboxed_nativeint_array ->
         true
       | ( Variant { consts = consts1; non_consts = non_consts1 },

middle_end/flambda2/parser/fexpr.ml

@@ -355,7 +355,7 @@ type binop =
   | Bigarray_get_alignment of int
 
 type ternop =
-  (* XXX mshinwell: Array_set should use "array_set_kind" *)
+  (* CR mshinwell: Array_set should use "array_set_kind" *)
   | Array_set of array_kind * init_or_assign
   | Block_set of block_access_kind * init_or_assign
   | Bytes_or_bigstring_set of bytes_like_value * string_accessor_width

middle_end/flambda2/parser/fexpr_to_flambda.ml

@@ -452,7 +452,8 @@ let ternop env (ternop : Fexpr.ternop) : Flambda_primitive.ternary_primitive =
       | Values, ia -> Values (init_or_assign env ia)
       | (Naked_int32s | Naked_int64s | Naked_nativeints), _ ->
         Misc.fatal_error
-          "XXX fexpr support for unboxed int32/64/nativeint arrays"
+          "fexpr support for unboxed int32/64/nativeint arrays not yet \
+           implemented"
     in
     Array_set ask
   | Block_set (bk, ia) -> Block_set (block_access_kind bk, init_or_assign env ia)

middle_end/flambda2/parser/flambda_to_fexpr.ml

@@ -516,7 +516,7 @@ let nullop _env (op : Flambda_primitive.nullary_primitive) : Fexpr.nullop =
 
 let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop =
   match op with
-  | Array_length _ak -> Array_length (Array_kind Values) (* XXX *)
+  | Array_length ak -> Array_length ak
   | Box_number (bk, alloc) ->
     Box_number (bk, alloc_mode_for_allocations env alloc)
   | Tag_immediate -> Tag_immediate

middle_end/flambda2/simplify/rebuilt_static_const.ml

@@ -151,7 +151,7 @@ let create_immutable_float_block are_rebuilding fields =
     Block_not_rebuilt { free_names }
   else create_normal_non_code (SC.immutable_float_block fields)
 
-let create_immutable_float_array are_rebuilding fields =
+let create_immutable_naked_number_array builder are_rebuilding fields =
   if ART.do_not_rebuild_terms are_rebuilding
   then
     let free_names =
@@ -160,40 +160,19 @@ let create_immutable_float_array are_rebuilding fields =
           Name_occurrences.union free_names (Or_variable.free_names field))
     in
     Block_not_rebuilt { free_names }
-  else create_normal_non_code (SC.immutable_float_array fields)
+  else create_normal_non_code (builder fields)
 
-let create_immutable_int32_array are_rebuilding fields =
-  if ART.do_not_rebuild_terms are_rebuilding
-  then
-    let free_names =
-      ListLabels.fold_left fields ~init:Name_occurrences.empty
-        ~f:(fun free_names field ->
-          Name_occurrences.union free_names (Or_variable.free_names field))
-    in
-    Block_not_rebuilt { free_names }
-  else create_normal_non_code (SC.immutable_int32_array fields)
+let create_immutable_float_array =
+  create_immutable_naked_number_array SC.immutable_float_array
 
-let create_immutable_int64_array are_rebuilding fields =
-  if ART.do_not_rebuild_terms are_rebuilding
-  then
-    let free_names =
-      ListLabels.fold_left fields ~init:Name_occurrences.empty
-        ~f:(fun free_names field ->
-          Name_occurrences.union free_names (Or_variable.free_names field))
-    in
-    Block_not_rebuilt { free_names }
-  else create_normal_non_code (SC.immutable_int64_array fields)
+let create_immutable_int32_array =
+  create_immutable_naked_number_array SC.immutable_int32_array
 
-let create_immutable_nativeint_array are_rebuilding fields =
-  if ART.do_not_rebuild_terms are_rebuilding
-  then
-    let free_names =
-      ListLabels.fold_left fields ~init:Name_occurrences.empty
-        ~f:(fun free_names field ->
-          Name_occurrences.union free_names (Or_variable.free_names field))
-    in
-    Block_not_rebuilt { free_names }
-  else create_normal_non_code (SC.immutable_nativeint_array fields)
+let create_immutable_int64_array =
+  create_immutable_naked_number_array SC.immutable_int64_array
+
+let create_immutable_nativeint_array =
+  create_immutable_naked_number_array SC.immutable_nativeint_array
 
 let create_immutable_value_array are_rebuilding fields =
   if ART.do_not_rebuild_terms are_rebuilding