Merge branch 'main' into dkalinichenko/move-unboxed-defs-to-stable

Author: d-kalinichenko

HACKING.md

@@ -96,10 +96,7 @@ To rebuild after making changes, you can just type `make`. You need to
 have a working OCaml 4.14 or 4.14.1 compiler on your PATH before doing so,
 e.g. installed via OPAM. You also need to have dune and menhir.
 
-<!-- CR someone: investigate this -->
-The build currently fails when using the latest version of `dune` (3.11.1).
-To install a known-good dune, run `opam pin add dune 3.8.1`. `menhir` should be pinned to a specific
-version as well: `opam pin add menhir 20210419`.
+`menhir` should be pinned to a specific version: `opam pin add menhir 20210419`.
 
 There is a special target `make hacking` which starts Dune in polling mode.  The rebuild
 performed here is equivalent to `make ocamlopt` in the upstream distribution: it rebuilds the

backend/.ocamlformat-enable

@@ -4,8 +4,8 @@ cmm_builtins.ml
 cmm_builtins.mli
 checks.ml
 checks.mli
-checkmach.ml
-checkmach.mli
+zero_alloc_checker.ml
+zero_alloc_checker.mli
 cfg/**/*.ml
 cfg/**/*.mli
 asm_targets/**/*.ml

backend/asmgen.ml

@@ -86,7 +86,7 @@ let (pass_to_cfg : Cfg_format.cfg_unit_info Compiler_pass_map.t) =
   |> Compiler_pass_map.add Compiler_pass.Selection (new_cfg_unit_info ())
 
 let reset () =
-  Checkmach.reset_unit_info ();
+  Zero_alloc_checker.reset_unit_info ();
   start_from_emit := false;
   Compiler_pass_map.iter (fun pass (cfg_unit_info : Cfg_format.cfg_unit_info) ->
     if should_save_ir_after pass then begin
@@ -277,8 +277,8 @@ let compile_fundecl ~ppf_dump ~funcnames fd_cmm =
   ++ Profile.record ~accumulate:true "polling"
        (Polling.instrument_fundecl ~future_funcnames:funcnames)
   ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_polling
-  ++ Profile.record ~accumulate:true "checkmach"
-       (Checkmach.fundecl ~future_funcnames:funcnames ppf_dump)
+  ++ Profile.record ~accumulate:true "zero_alloc_checker"
+       (Zero_alloc_checker.fundecl ~future_funcnames:funcnames ppf_dump)
   ++ (fun fd ->
       match !Flambda_backend_flags.cfg_cse_optimize with
       | false ->
@@ -460,9 +460,9 @@ let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename ~may_reduc
        Misc.try_finally
          (fun () ->
             gen ();
-            Checkmach.record_unit_info ppf_dump;
+            Zero_alloc_checker.record_unit_info ppf_dump;
             Compiler_hooks.execute Compiler_hooks.Check_allocations
-              Checkmach.iter_witnesses;
+              Zero_alloc_checker.iter_witnesses;
             write_ir output_prefix)
          ~always:(fun () ->
              if create_asm then close_out !Emitaux.output_channel)

backend/cfg/cfg.ml

@@ -57,7 +57,8 @@ let rec of_cmm_codegen_option : Cmm.codegen_option list -> codegen_option list =
     match hd with
     | No_CSE -> No_CSE :: of_cmm_codegen_option tl
     | Reduce_code_size -> Reduce_code_size :: of_cmm_codegen_option tl
-    | Use_linscan_regalloc | Assume _ | Check _ -> of_cmm_codegen_option tl)
+    | Use_linscan_regalloc | Assume_zero_alloc _ | Check_zero_alloc _ ->
+      of_cmm_codegen_option tl)
 
 type t =
   { blocks : basic_block Label.Tbl.t;

backend/cmm.ml

@@ -312,17 +312,14 @@ type expression =
       * Backend_var.With_provenance.t * expression * Debuginfo.t
       * kind_for_unboxing
 
-type property =
-  | Zero_alloc
-
 type codegen_option =
   | Reduce_code_size
   | No_CSE
   | Use_linscan_regalloc
-  | Assume of { property: property; strict: bool; never_returns_normally: bool;
-                never_raises: bool;
-                loc: Location.t }
-  | Check of { property: property; strict: bool; loc : Location.t; }
+  | Assume_zero_alloc of { strict: bool; never_returns_normally: bool;
+                           never_raises: bool;
+                           loc: Location.t }
+  | Check_zero_alloc of { strict: bool; loc : Location.t; }
 
 type fundecl =
   { fun_name: symbol;
@@ -686,6 +683,4 @@ let equal_integer_comparison left right =
   | Cge, (Ceq | Cne | Clt | Cgt | Cle) ->
     false
 
-let all_properties = [Zero_alloc]
-
 let caml_flambda2_invalid = "caml_flambda2_invalid"

backend/cmm.mli

@@ -314,17 +314,14 @@ type expression =
         active.  This allows for sharing a single handler in several places, or
         having multiple entry and exit points to a single trywith block. *)
 
-type property =
-  | Zero_alloc
-
 type codegen_option =
   | Reduce_code_size
   | No_CSE
   | Use_linscan_regalloc
-  | Assume of { property: property; strict: bool; never_returns_normally: bool;
+  | Assume_zero_alloc of { strict: bool; never_returns_normally: bool;
                 never_raises: bool;
                 loc: Location.t }
-  | Check of { property: property; strict: bool; loc: Location.t }
+  | Check_zero_alloc of { strict: bool; loc: Location.t }
 
 type fundecl =
   { fun_name: symbol;
@@ -401,6 +398,5 @@ val equal_float_width : float_width -> float_width -> bool
 val equal_float_comparison : float_comparison -> float_comparison -> bool
 val equal_memory_chunk : memory_chunk -> memory_chunk -> bool
 val equal_integer_comparison : integer_comparison -> integer_comparison -> bool
-val all_properties : property list
 
 val caml_flambda2_invalid : string

backend/cmm_helpers.ml

@@ -1287,6 +1287,35 @@ let setfield_unboxed_int64_or_nativeint arr ofs newval dbg =
          [array_indexing log2_size_addr arr ofs dbg; newval],
          dbg ))
 
+(* Getters and setters for unboxed float32 fields *)
+
+let get_field_unboxed_float32 mutability ~block ~index dbg =
+  (* CR layouts v5.1: Properly support big-endian. *)
+  if Arch.big_endian
+  then
+    Misc.fatal_error
+      "Unboxed float32 fields only supported on little-endian architectures";
+  let memory_chunk = Single { reg = Float32 } in
+  (* CR layouts v5.1: We'll need to vary log2_size_addr to efficiently pack
+   * float32s *)
+  let field_address = array_indexing log2_size_addr block index dbg in
+  Cop
+    (Cload { memory_chunk; mutability; is_atomic = false }, [field_address], dbg)
+
+let setfield_unboxed_float32 arr ofs newval dbg =
+  (* CR layouts v5.1: Properly support big-endian. *)
+  if Arch.big_endian
+  then
+    Misc.fatal_error
+      "Unboxed float32 fields only supported on little-endian architectures";
+  (* CR layouts v5.1: We will need to vary log2_size_addr when float32 fields
+     are efficiently packed. *)
+  return_unit dbg
+    (Cop
+       ( Cstore (Single { reg = Float32 }, Assignment),
+         [array_indexing log2_size_addr arr ofs dbg; newval],
+         dbg ))
+
 (* String length *)
 
 (* Length of string block *)
@@ -1566,12 +1595,13 @@ let make_mixed_alloc ~mode dbg tag shape args =
       match flat_suffix.(idx - value_prefix_len) with
       | Imm -> int_array_set arr ofs newval dbg
       | Float | Float64 -> float_array_set arr ofs newval dbg
+      | Float32 -> setfield_unboxed_float32 arr ofs newval dbg
       | Bits32 -> setfield_unboxed_int32 arr ofs newval dbg
       | Bits64 | Word -> setfield_unboxed_int64_or_nativeint arr ofs newval dbg
   in
   let size =
-    (* CR layouts 5.1: When we pack int32s more efficiently, this code will need
-       to change. *)
+    (* CR layouts 5.1: When we pack int32s/float32s more efficiently, this code
+       will need to change. *)
     value_prefix_len + Array.length flat_suffix
   in
   if size_float <> size_addr

backend/cmm_helpers.mli

@@ -1006,7 +1006,8 @@ val unboxed_int64_or_nativeint_array_set :
   Debuginfo.t ->
   expression
 
-(** {2 Getters and setters for unboxed int fields of mixed blocks} *)
+(** {2 Getters and setters for unboxed int and float32 fields of mixed
+    blocks} *)
 
 (** The argument structure for getters is parallel to [get_field_computed]. *)
 
@@ -1017,6 +1018,13 @@ val get_field_unboxed_int32 :
   Debuginfo.t ->
   expression
 
+val get_field_unboxed_float32 :
+  Asttypes.mutable_flag ->
+  block:expression ->
+  index:expression ->
+  Debuginfo.t ->
+  expression
+
 val get_field_unboxed_int64_or_nativeint :
   Asttypes.mutable_flag ->
   block:expression ->
@@ -1032,4 +1040,6 @@ val get_field_unboxed_int64_or_nativeint :
 
 val setfield_unboxed_int32 : ternary_primitive
 
+val setfield_unboxed_float32 : ternary_primitive
+
 val setfield_unboxed_int64_or_nativeint : ternary_primitive

backend/printcmm.ml

@@ -392,21 +392,17 @@ and sequence ppf = function
 
 and expression ppf e = fprintf ppf "%a" expr e
 
-let property_to_string : Cmm.property -> string = function
-  | Zero_alloc -> "zero_alloc"
-
 let codegen_option = function
   | Reduce_code_size -> "reduce_code_size"
   | No_CSE -> "no_cse"
   | Use_linscan_regalloc -> "linscan"
-  | Assume { property; strict; never_returns_normally = _; loc = _ } ->
-    Printf.sprintf "assume_%s%s%s"
-      (property_to_string property)
+  | Assume_zero_alloc { strict; never_returns_normally; never_raises; loc = _ } ->
+    Printf.sprintf "assume_zero_alloc_%s%s%s"
       (if strict then "_strict" else "")
-      (if strict then "_never_returns_normally" else "")
-  | Check { property; strict; loc = _ } ->
-    Printf.sprintf "assert_%s%s"
-      (property_to_string property)
+      (if never_returns_normally then "_never_returns_normally" else "")
+      (if never_raises then "_never_raises" else "")
+  | Check_zero_alloc { strict; loc = _ } ->
+    Printf.sprintf "assert_zero_alloc%s"
       (if strict then "_strict" else "")
 
 let print_codegen_options ppf l =

backend/printcmm.mli

@@ -34,5 +34,4 @@ val fundecl : formatter -> Cmm.fundecl -> unit
 val data : formatter -> Cmm.data_item list -> unit
 val phrase : formatter -> Cmm.phrase -> unit
 val temporal_locality : Cmm.prefetch_temporal_locality_hint -> string
-val property_to_string : Cmm.property -> string
 val print_codegen_options : formatter -> Cmm.codegen_option list -> unit

backend/selectgen.ml

@@ -206,8 +206,9 @@ let size_component : machtype_component -> int = function
   | Int -> Arch.size_int
   | Float -> Arch.size_float
   | Float32 ->
-    assert (Arch.size_float = 8);
-    Arch.size_float / 2
+    (* CR layouts v5.1: reconsider when float32 fields are efficiently packed.
+       Note that packed float32# arrays are handled via a separate path. *)
+    Arch.size_float
   | Vec128 -> Arch.size_vec128
 
 let size_machtype mty =
@@ -222,10 +223,11 @@ let size_expr (env:environment) exp =
       Cconst_int _ | Cconst_natint _ -> Arch.size_int
     | Cconst_symbol _ ->
         Arch.size_addr
-    | Cconst_float32 _ ->
-      assert (Arch.size_float = 8);
-      Arch.size_float / 2
     | Cconst_float _ -> Arch.size_float
+    | Cconst_float32 _ ->
+      (* CR layouts v5.1: reconsider when float32 fields are efficiently packed.
+         Note that packed float32# arrays are handled via a separate path. *)
+      Arch.size_float
     | Cconst_vec128 _ -> Arch.size_vec128
     | Cvar id ->
         begin try
@@ -1751,7 +1753,8 @@ method private emit_tail_sequence ?at_start env exp =
 method emit_fundecl ~future_funcnames f =
   current_function_name := f.Cmm.fun_name.sym_name;
   current_function_is_check_enabled :=
-    Checkmach.is_check_enabled f.Cmm.fun_codegen_options f.Cmm.fun_name.sym_name f.Cmm.fun_dbg;
+    Zero_alloc_checker.is_check_enabled f.Cmm.fun_codegen_options
+      f.Cmm.fun_name.sym_name f.Cmm.fun_dbg;
   let num_regs_per_arg = Array.make (List.length f.Cmm.fun_args) 0 in
   let rargs =
     List.mapi