Lots of fixes after rebase (makes separate commits useless)

too much diff to fix up in the right commit

Author: gretay-js

backend/cfg/cfg.ml

@@ -57,8 +57,7 @@ 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_zero_alloc _ | Check_zero_alloc _
-      ->
+    | Use_linscan_regalloc | Assume_zero_alloc _ | Check_zero_alloc _ ->
       of_cmm_codegen_option tl)
 
 type t =

backend/cmm.mli

@@ -318,7 +318,7 @@ type codegen_option =
   | Reduce_code_size
   | No_CSE
   | Use_linscan_regalloc
-  | Assume of { strict: bool; never_returns_normally: bool;
+  | 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 }

backend/zero_alloc_checker.ml

@@ -1467,7 +1467,8 @@ end = struct
                 never_raises = false;
                 loc
               }
-          | Assume_zero_alloc { never_returns_normally; never_raises; loc } ->
+          | Assume_zero_alloc
+              { strict; never_returns_normally; never_raises; loc } ->
             Some
               { strict;
                 assume = true;
@@ -1853,7 +1854,11 @@ end = struct
      in cmx and memory consumption Compilenv. Different components have
      different frequencies of Top/Bot. The most likely value is encoded as None
      (i.e., not stored). *)
-  let encode (v : V.t) = match v with Top _ -> 0 | Safe -> 1 | Bot -> 2
+  let encode (v : V.t) =
+    V.match_with v
+      ~top:(fun _ -> 0)
+      ~safe:1 ~bot:2
+      ~unresolved:(fun () -> assert false)
 
   (* Witnesses are not used across functions and not stored in cmx. Witnesses
      that appear in a function's summary are only used for error messages about
@@ -1862,9 +1867,9 @@ end = struct
   let decoded_witness = Witnesses.empty
 
   let decode = function
-    | 0 -> V.Top decoded_witness
-    | 1 -> V.Safe
-    | 2 -> V.Bot
+    | 0 -> V.top decoded_witness
+    | 1 -> V.safe
+    | 2 -> V.bot
     | n -> Misc.fatal_errorf "Zero_alloc_checker cannot decode %d" n
 
   let encode (v : Value.t) : Checks.value =
@@ -2110,10 +2115,10 @@ end = struct
   (** Summary of target specific operations. *)
   let transform_specific w s =
     (* Conservatively assume that operation can return normally. *)
-    let nor = if Arch.operation_allocates s then V.Top w else V.Safe in
-    let exn = if Arch.operation_can_raise s then nor else V.Bot in
+    let nor = if Arch.operation_allocates s then V.top w else V.safe in
+    let exn = if Arch.operation_can_raise s then nor else V.bot in
     (* Assume that the operation does not diverge. *)
-    let div = V.Bot in
+    let div = V.bot in
     { Value.nor; exn; div }
 
   let transform_operation t (op : Mach.operation) ~next ~exn dbg =

driver/flambda_backend_args.ml

@@ -672,10 +672,10 @@ module type Flambda_backend_options = sig
   val heap_reduction_threshold : int -> unit
   val zero_alloc_check : string -> unit
   val dzero_alloc : unit -> unit
-  val disable_zero_alloc : unit -> unit
-  val disable_precise_zero_alloc : unit -> unit
-  val zero_alloc_details_cutoff : int -> unit
-  val zero_alloc_join : int -> unit
+  val disable_zero_alloc_checker : unit -> unit
+  val disable_precise_zero_alloc_checker : unit -> unit
+  val zero_alloc_checker_details_cutoff : int -> unit
+  val zero_alloc_checker_join : int -> unit
 
   val function_layout : string -> unit
   val disable_poll_insertion : unit -> unit
@@ -969,13 +969,13 @@ module Flambda_backend_options_impl = struct
     in
     Flambda_backend_flags.zero_alloc_checker_details_cutoff := c
 
-  let checkmach_join n =
-    let c : Flambda_backend_flags.checkmach_join =
+  let zero_alloc_checker_join n =
+    let c : Flambda_backend_flags.zero_alloc_checker_join =
       if n < 0 then Error (-n)
       else if n = 0 then Keep_all
       else Widen n
     in
-    Flambda_backend_flags.checkmach_join := c
+    Flambda_backend_flags.zero_alloc_checker_join := c
 
   let function_layout s =
     match Flambda_backend_flags.Function_layout.of_string s with
@@ -1266,10 +1266,10 @@ module Extra_params = struct
       | None -> ()
       end;
       true
-    | "checkmach-join" ->
+    | "zero-alloc-checker-join" ->
       begin match Compenv.check_int ppf name v with
       | Some i ->
-        Flambda_backend_options_impl.checkmach_join i
+        Flambda_backend_options_impl.zero_alloc_checker_join i
       | None -> ()
       end;
       true

driver/flambda_backend_flags.ml

@@ -47,14 +47,14 @@ let default_zero_alloc_checker_details_cutoff = At_most 20
 let zero_alloc_checker_details_cutoff = ref default_zero_alloc_checker_details_cutoff
                                        (* -zero-alloc-checker-details-cutoff n *)
 
-type checkmach_join =
+type zero_alloc_checker_join =
   | Keep_all
   | Widen of int  (* n > 0 *)
   | Error of int (* n > 0 *)
 
-let default_checkmach_join = Widen 100
-let checkmach_join = ref default_checkmach_join
-                              (* -checkmach-precise-join-threshold n *)
+let default_zero_alloc_checker_join = Widen 100
+let zero_alloc_checker_join = ref default_zero_alloc_checker_join
+                              (* -zero-alloc-checker-join n *)
 
 module Function_layout = struct
   type t =

driver/flambda_backend_flags.mli

@@ -49,13 +49,13 @@ type zero_alloc_checker_details_cutoff =
 val zero_alloc_checker_details_cutoff : zero_alloc_checker_details_cutoff ref
 val default_zero_alloc_checker_details_cutoff : zero_alloc_checker_details_cutoff
 
-type checkmach_join =
+type zero_alloc_checker_join =
   | Keep_all
   | Widen of int  (* n > 0 *)
   | Error of int (* n > 0 *)
 
-val checkmach_join : checkmach_join ref
-val default_checkmach_join : checkmach_join
+val zero_alloc_checker_join : zero_alloc_checker_join ref
+val default_zero_alloc_checker_join : zero_alloc_checker_join
 
 module Function_layout : sig
   type t =

middle_end/flambda2/parser/fexpr_to_flambda.ml

@@ -924,7 +924,8 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t =
             ~first_complex_local_param:(Flambda_arity.num_params params_arity)
             ~result_arity ~result_types:Unknown ~result_mode
             ~contains_no_escaping_local_allocs:false ~stub:false ~inline
-            ~check:Default (* CR gyorsh: should [check] be set properly? *)
+            ~check:Default_check
+              (* CR gyorsh: should [check] be set properly? *)
             ~is_a_functor:false ~is_opaque:false ~recursive
             ~cost_metrics (* CR poechsel: grab inlining arguments from fexpr. *)
             ~inlining_arguments:(Inlining_arguments.create ~round:0)

middle_end/flambda2/simplify/simplify_apply_expr.ml

@@ -631,7 +631,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply
                 (Code_metadata.contains_no_escaping_local_allocs
                    callee's_code_metadata)
               ~stub:true ~inline:Default_inline ~poll_attribute:Default
-              ~check:Check_attribute.Default_check ~is_a_functor:false
+              ~check:Zero_alloc_attribute.Default_check ~is_a_functor:false
               ~is_opaque:false ~recursive ~cost_metrics:cost_metrics_of_body
               ~inlining_arguments:(DE.inlining_arguments (DA.denv dacc))
               ~dbg ~is_tupled:false

middle_end/flambda2/simplify/simplify_set_of_closures.ml

@@ -510,8 +510,8 @@ let simplify_function context ~outer_dacc function_slot code_id
     let never_delete =
       match Code_metadata.check code_metadata with
       | Default_check -> !Clflags.zero_alloc_check_assert_all
-      | Assume  _  -> false
-      | Check _  -> true
+      | Assume _ -> false
+      | Check _ -> true
     in
     if never_delete then Code_id.Set.singleton code_id else Code_id.Set.empty
   in

middle_end/flambda2/terms/zero_alloc_attribute.ml

@@ -26,8 +26,7 @@ type t =
 let print ppf t =
   match t with
   | Default_check -> ()
-  | Assume { strict; never_returns_normally; never_raises; loc = _ }
-    ->
+  | Assume { strict; never_returns_normally; never_raises; loc = _ } ->
     Format.fprintf ppf "@[assume_zero_alloc%s%s%s@]"
       (if strict then "_strict" else "")
       (if never_returns_normally then "_never_returns_normally" else "")
@@ -36,25 +35,17 @@ let print ppf t =
     Format.fprintf ppf "@[assert_zero_alloc%s@]"
       (if strict then "_strict" else "")
 
-let from_lambda : Lambda.check_attribute -> Location.t -> t =
+let from_lambda : Lambda.zero_alloc_attribute -> Location.t -> t =
  fun a loc ->
   match a with
-  | Default_check ->
+  | Default_zero_alloc ->
     if !Clflags.zero_alloc_check_assert_all
-       && Builtin_attributes.is_check_enabled ~opt:false Zero_alloc
+       && Builtin_attributes.is_zero_alloc_check_enabled ~opt:false
     then Check { strict = false; loc }
     else Default_check
   | Ignore_assert_all -> Default_check
-  | Assume
-      { strict; never_returns_normally; never_raises; loc; arity = _ }
-    ->
-    Assume
-      {
-        strict;
-        never_returns_normally;
-        never_raises;
-        loc
-      }
+  | Assume { strict; never_returns_normally; never_raises; loc; arity = _ } ->
+    Assume { strict; never_returns_normally; never_raises; loc }
   | Check { strict; opt; loc; arity = _ } ->
     if Builtin_attributes.is_zero_alloc_check_enabled ~opt
     then Check { strict; loc }
@@ -63,29 +54,24 @@ let from_lambda : Lambda.check_attribute -> Location.t -> t =
 let equal x y =
   match x, y with
   | Default_check, Default_check -> true
-  | ( Check { strict = s1; loc = loc1 },
-      Check { strict = s2; loc = loc2 } ) ->
+  | Check { strict = s1; loc = loc1 }, Check { strict = s2; loc = loc2 } ->
     Bool.equal s1 s2 && Location.compare loc1 loc2 = 0
   | ( Assume
-        {
-          strict = s1;
+        { strict = s1;
           never_returns_normally = n1;
           never_raises = r1;
           loc = loc1
         },
       Assume
-        {
-          strict = s2;
+        { strict = s2;
           never_returns_normally = n2;
           never_raises = r2;
           loc = loc2
         } ) ->
-    Bool.equal s1 s2 && Bool.equal n1 n2
-    && Bool.equal r1 r2
+    Bool.equal s1 s2 && Bool.equal n1 n2 && Bool.equal r1 r2
     && Location.compare loc1 loc2 = 0
   | (Default_check | Check _ | Assume _), _ -> false
 
 let is_default : t -> bool = function
   | Default_check -> true
   | Check _ | Assume _ -> false
-

middle_end/flambda2/terms/zero_alloc_attribute.mli

@@ -29,5 +29,4 @@ val equal : t -> t -> bool
 
 val is_default : t -> bool
 
-val from_lambda : Lambda.zero_aloc_attribute -> Location.t -> t
-
+val from_lambda : Lambda.zero_alloc_attribute -> Location.t -> t

middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml

@@ -349,14 +349,8 @@ let transl_check_attrib : Zero_alloc_attribute.t -> Cmm.codegen_option list =
   function
   | Default_check -> []
   | Assume { strict; never_returns_normally; never_raises; loc } ->
-    [ Assume_zero_alloc
-        { strict;
-          never_returns_normally;
-          never_raises;
-          loc
-        } ]
-  | Check { strict; loc } ->
-    [Check_zero_alloc { strict; loc }]
+    [Assume_zero_alloc { strict; never_returns_normally; never_raises; loc }]
+  | Check { strict; loc } -> [Check_zero_alloc { strict; loc }]
 
 (* Translation of the bodies of functions. *)
 

native_toplevel/opttoploop.ml

@@ -344,7 +344,7 @@ let name_expression ~loc ~attrs sort exp =
       val_kind = Val_reg;
       val_loc = loc;
       val_attributes = attrs;
-      val_zero_alloc = Default_check;
+      val_zero_alloc = Default_zero_alloc;
       val_uid = Uid.internal_not_actually_unique; }
   in
   let sg = [Sig_value(id, vd, Exported)] in

ocaml/lambda/lambda.ml

@@ -626,7 +626,7 @@ type poll_attribute =
   | Default_poll (* no [@poll] attribute *)
 
 type zero_alloc_attribute = Builtin_attributes.zero_alloc_attribute =
-  | Default_check
+  | Default_zero_alloc
   | Ignore_assert_all
   | Check of { strict: bool;
                opt: bool;

ocaml/lambda/lambda.mli

@@ -501,7 +501,7 @@ type poll_attribute =
   | Error_poll (* [@poll error] *)
   | Default_poll (* no [@poll] attribute *)
 
-type zero_alloc_attribute = Builtin_attributes.check_attribute =
+type zero_alloc_attribute = Builtin_attributes.zero_alloc_attribute =
   | Default_zero_alloc
   | Ignore_assert_all
   | Check of { strict: bool;

ocaml/lambda/translattribute.ml

@@ -444,12 +444,6 @@ let add_function_attributes lam loc attr =
     add_local_attribute lam loc attr
   in
   let lam =
-<<<<<<< HEAD
-=======
-    add_zero_alloc_attribute lam loc attr
-  in
-  let lam =
->>>>>>> 2bb76db708 (Remove "Lambda.property" and rename "Lambda.check_attribute" and)
     add_loop_attribute lam loc attr
   in
   let lam =

ocaml/lambda/translcore.ml

@@ -1603,7 +1603,7 @@ and transl_function ~in_new_scope ~scopes e params body
            ~scopes e.exp_loc repr ~region params body)
   in
   let attr =
-    { function_attribute_disallowing_arity_fusion with check = zero_alloc }
+    { function_attribute_disallowing_arity_fusion with zero_alloc }
   in
   let loc = of_location ~scopes e.exp_loc in
   let body = if region then maybe_region_layout return body else body in

ocaml/parsing/builtin_attributes.ml

@@ -698,8 +698,8 @@ let is_zero_alloc_check_enabled ~opt =
   | Check_default -> not opt
   | Check_opt_only -> opt
 
-let is_zero_alloc_attribute = function
-  | Zero_alloc -> [ ["zero_alloc"; "ocaml.zero_alloc"], true ]
+let is_zero_alloc_attribute =
+  [ ["zero_alloc"; "ocaml.zero_alloc"], true ]
 
 let get_payload get_from_exp =
   let open Parsetree in
@@ -860,12 +860,12 @@ let parse_zero_alloc_payload ~loc ~arity ~warn ~empty payload =
   | _ :: _ ->
     let payload = List.sort String.compare payload in
     match List.assoc_opt payload zero_alloc_lookup_table with
-    | None -> warn (); Default_check
+    | None -> warn ();  Default_zero_alloc
     | Some ca -> ca arity loc
 
 let parse_zero_alloc_attribute ~is_arity_allowed ~default_arity attr =
   match attr with
-  | None -> Default_check
+  | None -> Default_zero_alloc
   | Some {Parsetree.attr_name = {txt; loc}; attr_payload = payload} ->
     let warn () =
       let ( %> ) f g x = g (f x) in
@@ -881,7 +881,7 @@ let parse_zero_alloc_attribute ~is_arity_allowed ~default_arity attr =
       Check { strict = false; opt = false; arity; loc; }
     in
     match get_optional_payload get_ids_and_constants_from_exp payload with
-    | Error () -> warn (); Default_check
+    | Error () -> warn (); Default_zero_alloc
     | Ok None -> empty default_arity
     | Ok (Some payload) ->
       let arity, payload =
@@ -898,29 +898,29 @@ let parse_zero_alloc_attribute ~is_arity_allowed ~default_arity attr =
       in
       parse_zero_alloc_payload ~loc ~arity ~warn ~empty:(empty arity) payload
 
-let get_zero_alloc_attribute ~in_signature ~default_arity l p =
+let get_zero_alloc_attribute ~in_signature ~default_arity l =
   let attr = find_attribute is_zero_alloc_attribute l in
   let res =
       parse_zero_alloc_attribute ~is_arity_allowed:in_signature ~default_arity
         attr
   in
   (match attr, res with
-   | None, Default_check -> ()
-   | _, Default_check -> ()
+   | None, Default_zero_alloc -> ()
+   | _, Default_zero_alloc -> ()
    | None, (Check _ | Assume _ | Ignore_assert_all) -> assert false
    | Some _, Ignore_assert_all -> ()
    | Some _, Assume _ -> ()
    | Some attr, Check { opt; _ } ->
-     if not in_signature && is_check_enabled ~opt p && !Clflags.native_code then
+     if not in_signature && is_zero_alloc_check_enabled ~opt && !Clflags.native_code then
        (* The warning for unchecked functions will not trigger if the check is
           requested through the [@@@zero_alloc all] top-level annotation rather
           than through the function annotation [@zero_alloc]. *)
-       register_property attr.attr_name);
+       register_zero_alloc_attribute attr.attr_name);
    res
 
 let assume_zero_alloc ~is_check_allowed check : Zero_alloc_utils.Assume_info.t =
   match check with
-  | Default_check -> Zero_alloc_utils.Assume_info.none
+  | Default_zero_alloc -> Zero_alloc_utils.Assume_info.none
   | Ignore_assert_all -> Zero_alloc_utils.Assume_info.none
   | Assume { strict; never_returns_normally; never_raises; } ->
     Zero_alloc_utils.Assume_info.create ~strict ~never_returns_normally ~never_raises