flambda-backend: zero_alloc attribute payload "assert all" and "ignor…

…e" (ocaml-flambda#1296)

* Support [@@@zero_alloc all]

* Add [@zero_alloc ignore]

* Update test output to match new attributes

* Format

* Add tests for new payloads of zero_alloc attributes

* Ignore entry functions for the purpose of [@@@zero_alloc all]

* Handle warning about unchecked attributes correctly for ignore

* Add a comment

* Using "assert" as payload is probably a bad idea

* Improve tests

* Fix comment

* Don't accept synonyms of [@@@zero_alloc all]

Mostly because using "assert" might be confusing (for human users and
parser) with the language construct "assert <e>". This payload was
removed from function attribute [@zero_alloc] in a previous commit.

lambda/lambda.ml

@@ -442,6 +442,7 @@ type poll_attribute =
 
 type check_attribute =
   | Default_check
+  | Ignore_assert_all of property
   | Check of { property: property;
                strict: bool;
                assume: bool;

lambda/lambda.mli

@@ -323,6 +323,7 @@ type poll_attribute =
 
 type check_attribute =
   | Default_check
+  | Ignore_assert_all of property
   | Check of { property: property;
                strict: bool;
                (* [strict=true] property holds on all paths.
@@ -331,7 +332,7 @@ type check_attribute =
                   exceptional returns or divering loops are ignored).
                   This definition may not be applicable to new properties. *)
                assume: bool;
-               (* [assume=false] assume without checking that the
+               (* [assume=true] assume without checking that the
                   property holds *)
                loc: Location.t;
              }

lambda/printlambda.ml

@@ -580,6 +580,8 @@ let check_attribute ppf check =
   in
   match check with
   | Default_check -> ()
+  | Ignore_assert_all p ->
+    fprintf ppf "ignore assert all %s@ " (check_property p)
   | Check {property=p; assume; strict; loc = _} ->
     fprintf ppf "%s %s%s@ "
       (if assume then "assume" else "assert")

lambda/translattribute.ml

@@ -144,7 +144,7 @@ let parse_ids_payload txt loc ~default ~empty cases payload =
   | Error () -> warn ()
   | Ok None -> empty
   | Ok (Some ids) ->
-      match List.assoc_opt ids cases with
+      match List.assoc_opt (List.sort String.compare ids) cases with
       | Some r -> r
       | None -> warn ()
 
@@ -256,7 +256,7 @@ let parse_property_attribute attr property =
           ["assume"], Check { property; strict = false; assume = true; loc; };
           ["strict"], Check { property; strict = true; assume = false; loc; };
           ["assume"; "strict"], Check { property; strict = true; assume = true; loc; };
-          ["strict"; "assume"], Check { property; strict = true; assume = true; loc; };
+          ["ignore"], Ignore_assert_all property
         ]
         payload
 
@@ -301,10 +301,15 @@ let get_property_attribute l p =
   let attr = find_attribute (is_property_attribute p) l in
   let res = parse_property_attribute attr p in
   (match attr, res with
-   | None, _ -> ()
+   | None, Default_check -> ()
    | _, Default_check -> ()
+   | None, (Check _ | Ignore_assert_all _ ) -> assert false
+   | Some _, Ignore_assert_all _ -> ()
    | Some attr, Check _ ->
      if !Clflags.zero_alloc_check && !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]. *)
        Builtin_attributes.register_property attr.attr_name);
    res
 
@@ -414,15 +419,18 @@ let add_check_attribute expr loc attributes =
         (if assume then "assume" else "assert")
         (to_string property)
         (if strict then " strict" else "")
+    | Ignore_assert_all property ->
+      Printf.sprintf "ignore %s" (to_string property)
     | Default_check -> assert false
   in
   match expr with
-  | Lfunction({ attr = { stub = false } as attr } as funct) ->
+  | Lfunction({ attr = { stub = false } as attr; } as funct) ->
     begin match get_check_attribute attributes with
     | Default_check -> expr
-    | (Check { property = p; _ }) as check ->
+    | (Ignore_assert_all p | Check { property = p; _ }) as check ->
       begin match attr.check with
       | Default_check -> ()
+      | Ignore_assert_all p'
       | Check { property = p'; strict = _; assume = _; loc = _; } ->
         if p = p' then
           Location.prerr_warning loc

parsing/builtin_attributes.ml

@@ -523,9 +523,11 @@ let zero_alloc_attribute (attr : Parsetree.attribute)  =
   parse_attribute_with_ident_payload attr
     ~name:"zero_alloc" ~f:(function
       | "check" -> Clflags.zero_alloc_check := true
+      | "all" ->
+        Clflags.zero_alloc_check_assert_all := true
       | _ ->
         warn_payload attr.attr_loc attr.attr_name.txt
-          "Only 'check' is supported")
+          "Only 'check' and 'all' are supported")
 
 let afl_inst_ratio_attribute attr =
   clflags_attribute_with_int_payload attr

utils/clflags.ml

@@ -633,4 +633,5 @@ let create_usage_msg program =
 let print_arguments program =
   Arg.usage !arg_spec (create_usage_msg program)
 
-let zero_alloc_check = ref false                   (* -zero-alloc-check *)
+let zero_alloc_check = ref false            (* -zero-alloc-check *)
+let zero_alloc_check_assert_all = ref false (* -zero-alloc-check-assert-all *)

utils/clflags.mli

@@ -285,3 +285,5 @@ val print_arguments : string -> unit
 val reset_arguments : unit -> unit
 
 val zero_alloc_check : bool ref
+val zero_alloc_check_assert_all : bool ref
+