Zero alloc misplaced attr warning

ocaml/lambda/translattribute.ml

@@ -54,9 +54,9 @@ let is_opaque_attribute =
   [ ["opaque"; "ocaml.opaque"], true ]
 
 
-let find_attribute p attributes =
+let find_attribute ?mark_used p attributes =
   let inline_attribute =
-    Builtin_attributes.filter_attributes
+    Builtin_attributes.filter_attributes ?mark:mark_used
       (Builtin_attributes.Attributes_filter.create p)
       attributes
   in
@@ -459,9 +459,9 @@ let add_local_attribute expr loc attributes =
     end
   | _ -> expr
 
-let assume_zero_alloc attributes =
+let assume_zero_alloc ?mark_used attributes =
   let p = Zero_alloc in
-  let attr = find_attribute (is_property_attribute p) attributes in
+  let attr = find_attribute ?mark_used (is_property_attribute p) attributes in
   match parse_property_attribute attr p with
   | Default_check -> false
   | Ignore_assert_all _ -> false
@@ -476,7 +476,7 @@ let get_assume_zero_alloc ~with_warnings attributes =
      that affect [Scoped_location] settings before translation
      of expressions in that scope.
      Warnings will be produced by [add_check_attribute]. *)
-    Warnings.without_warnings (fun () -> assume_zero_alloc attributes)
+    Warnings.without_warnings (fun () -> assume_zero_alloc ~mark_used:false attributes)
 
 let add_check_attribute expr loc attributes =
   let to_string = function

ocaml/parsing/builtin_attributes.ml

@@ -435,11 +435,11 @@ module Attributes_filter = struct
   let create (t : t) = t
 end
 
-let filter_attributes (nms_and_conds : Attributes_filter.t) attrs =
+let filter_attributes ?(mark=true) (nms_and_conds : Attributes_filter.t) attrs =
   List.filter (fun a ->
     List.exists (fun (nms, cond) ->
       if List.mem a.attr_name.txt nms
-      then (mark_used a.attr_name; cond)
+      then (if mark then mark_used a.attr_name; cond)
       else false)
       nms_and_conds
   ) attrs

ocaml/parsing/builtin_attributes.mli

@@ -159,6 +159,7 @@ end
     count as misplaced if the compiler could use it in some configuration.
 *)
 val filter_attributes :
+  ?mark:bool ->
   Attributes_filter.t -> Parsetree.attributes -> Parsetree.attributes
 
 val warn_on_literal_pattern: Parsetree.attributes -> bool

tests/backend/checkmach/dune.inc

@@ -635,3 +635,22 @@
  (enabled_if (= %{context_name} "main"))
  (deps test_misplaced_assume.output test_misplaced_assume.output.corrected)
  (action (diff test_misplaced_assume.output test_misplaced_assume.output.corrected)))
+
+(rule
+ (enabled_if (= %{context_name} "main"))
+ (targets test_misplaced_attr.output.corrected)
+ (deps (:ml test_misplaced_attr.ml) filter.sh)
+ (action
+   (with-outputs-to test_misplaced_attr.output.corrected
+    (pipe-outputs
+    (with-accepted-exit-codes 0
+     (run %{bin:ocamlopt.opt} %{ml} -g -color never -error-style short -c
+          -zero-alloc-check default -checkmach-details-cutoff 20 -O3))
+    (run "./filter.sh")
+   ))))
+
+(rule
+ (alias   runtest)
+ (enabled_if (= %{context_name} "main"))
+ (deps test_misplaced_attr.output test_misplaced_attr.output.corrected)
+ (action (diff test_misplaced_attr.output test_misplaced_attr.output.corrected)))

tests/backend/checkmach/gen/gen_dune.ml

@@ -127,4 +127,6 @@ let () =
   print_test_expected_output ~cutoff:default_cutoff ~flambda_only:false ~extra_dep:None ~exit_code:2 "test_assume_fail";
   print_test_expected_output ~cutoff:default_cutoff ~flambda_only:false ~extra_dep:None ~exit_code:2 "test_assume_on_call";
   print_test_expected_output ~cutoff:default_cutoff ~flambda_only:false ~extra_dep:None ~exit_code:2 "test_misplaced_assume";
+  print_test_expected_output ~cutoff:default_cutoff ~flambda_only:false ~extra_dep:None ~exit_code:0 "test_misplaced_attr";
+
   ()

tests/backend/checkmach/test_misplaced_attr.ml

@@ -0,0 +1,7 @@
+let[@zero_alloc assume] foo =
+  let x = 42 in
+  fun z -> z + x
+
+let[@zero_alloc] bar =
+  let x = 42 in
+  fun z -> z + x

tests/backend/checkmach/test_misplaced_attr.output

@@ -0,0 +1,5 @@
+File "test_misplaced_attr.ml", line 1, characters 5-15:
+Warning 53 [misplaced-attribute]: the "zero_alloc" attribute cannot appear in this context
+
+File "test_misplaced_attr.ml", line 5, characters 5-15:
+Warning 53 [misplaced-attribute]: the "zero_alloc" attribute cannot appear in this context