Issue misplaced attribute warning earlier (#2155)

Author: gretay-js

driver/optcompile.ml

@@ -39,6 +39,7 @@ let compile i typed ~transl_style ~unix ~pipeline =
   |> Compiler_hooks.execute_and_pipe Compiler_hooks.Raw_lambda
   |> Profile.(record generate)
    (fun program ->
+      Builtin_attributes.warn_unused ();
       let code = Simplif.simplify_lambda program.Lambda.code in
       { program with Lambda.code }
       |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program

ocaml/driver/compile.ml

@@ -36,6 +36,7 @@ let to_bytecode i Typedtree.{structure; coercion; _} =
     (Translmod.transl_implementation i.module_name ~style:Set_global_to_block)
   |> Profile.(record ~accumulate:true generate)
     (fun { Lambda.code = lambda; required_globals } ->
+       Builtin_attributes.warn_unused ();
        lambda
        |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.lambda
        |> Simplif.simplify_lambda

ocaml/driver/compile_common.ml

@@ -139,6 +139,6 @@ let implementation ~hook_parse_tree ~hook_typed_tree info ~backend =
         backend info typed
       end;
     end;
-    Builtin_attributes.warn_unused ();
+    Builtin_attributes.warn_unchecked_property ();
     Warnings.check_fatal ();
   )

ocaml/driver/optcompile.ml

@@ -40,6 +40,7 @@ let compile i ~backend ~middle_end ~transl_style
   |> print_if i.ppf_dump Clflags.dump_rawlambda Printlambda.program
   |> Profile.(record generate)
     (fun program ->
+       Builtin_attributes.warn_unused ();
        let code = Simplif.simplify_lambda program.Lambda.code in
        { program with Lambda.code }
        |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program

ocaml/parsing/builtin_attributes.ml

@@ -38,6 +38,10 @@ let mark_property_checked txt loc =
 let register_property attr =
     Attribute_table.replace unchecked_properties attr ()
 let warn_unchecked_property () =
+    (* When using -i, attributes will not have been translated, so we can't
+     warn about missing ones. *)
+  if !Clflags.print_types then ()
+  else
   let keys = List.of_seq (Attribute_table.to_seq_keys unchecked_properties) in
   let keys = List.sort attr_order keys in
   List.iter (fun sloc ->
@@ -50,7 +54,6 @@ let warn_unused () =
   if !Clflags.print_types then ()
   else
   begin
-    warn_unchecked_property ();
     let keys = List.of_seq (Attribute_table.to_seq_keys unused_attrs) in
     let keys = List.sort attr_order keys in
     List.iter (fun sloc ->

ocaml/parsing/builtin_attributes.mli

@@ -92,6 +92,7 @@ val mark_payload_attrs_used : Parsetree.payload -> unit
 (** Issue misplaced attribute warnings for all attributes created with
     [mk_internal] but not yet marked used. *)
 val warn_unused : unit -> unit
+val warn_unchecked_property : unit -> unit
 
 val check_alerts: Location.t -> Parsetree.attributes -> string -> unit
 val check_alerts_inclusion:

tests/backend/checkmach/dune.inc

@@ -597,3 +597,41 @@
  (enabled_if (= %{context_name} "main"))
  (deps test_assume_fail.output test_assume_fail.output.corrected)
  (action (diff test_assume_fail.output test_assume_fail.output.corrected)))
+
+(rule
+ (enabled_if (= %{context_name} "main"))
+ (targets test_assume_on_call.output.corrected)
+ (deps (:ml test_assume_on_call.ml) filter.sh)
+ (action
+   (with-outputs-to test_assume_on_call.output.corrected
+    (pipe-outputs
+    (with-accepted-exit-codes 2
+     (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_assume_on_call.output test_assume_on_call.output.corrected)
+ (action (diff test_assume_on_call.output test_assume_on_call.output.corrected)))
+
+(rule
+ (enabled_if (= %{context_name} "main"))
+ (targets test_misplaced_assume.output.corrected)
+ (deps (:ml test_misplaced_assume.ml) filter.sh)
+ (action
+   (with-outputs-to test_misplaced_assume.output.corrected
+    (pipe-outputs
+    (with-accepted-exit-codes 2
+     (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_assume.output test_misplaced_assume.output.corrected)
+ (action (diff test_misplaced_assume.output test_misplaced_assume.output.corrected)))

tests/backend/checkmach/gen/gen_dune.ml

@@ -125,4 +125,6 @@ let () =
   print_test ~extra_flags:"-zero-alloc-check opt" ~flambda_only:false "test_zero_alloc_opt1.ml";
   print_test ~extra_flags:"-zero-alloc-check opt" ~flambda_only:false "test_zero_alloc_opt2.ml";
   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";
   ()

tests/backend/checkmach/test_assume_on_call.ml

@@ -0,0 +1,14 @@
+let[@inline always] bar x = (x,x)
+
+(* The following functions currently report misplaced attribute warnings.
+   They are expected to compile successfully and pass the check
+   when zero_alloc annotations on function calls are supported. *)
+
+let[@zero_alloc] test1 x =
+  (bar[@zero_alloc]) x
+
+let[@zero_alloc] test2 x =
+  (bar[@zero_alloc assume strict]) x
+
+let[@zero_alloc] test3 x =
+  (bar[@zero_alloc assume never_returns_normally]) x

tests/backend/checkmach/test_assume_on_call.output

@@ -0,0 +1,26 @@
+File "test_assume_on_call.ml", line 8, characters 8-18:
+Warning 53 [misplaced-attribute]: the "zero_alloc" attribute cannot appear in this context
+
+File "test_assume_on_call.ml", line 11, characters 8-18:
+Warning 53 [misplaced-attribute]: the "zero_alloc" attribute cannot appear in this context
+
+File "test_assume_on_call.ml", line 14, characters 8-18:
+Warning 53 [misplaced-attribute]: the "zero_alloc" attribute cannot appear in this context
+
+File "test_assume_on_call.ml", line 7, characters 5-15:
+Error: Annotation check for zero_alloc failed on function Test_assume_on_call.test1 (camlTest_assume_on_call.test1_HIDE_STAMP)
+
+File "test_assume_on_call.ml", line 8, characters 2-22:
+Error: Unexpected allocation of 24 bytes (test_assume_on_call.ml:8,2--22;test_assume_on_call.ml:1,28--33)
+
+File "test_assume_on_call.ml", line 10, characters 5-15:
+Error: Annotation check for zero_alloc failed on function Test_assume_on_call.test2 (camlTest_assume_on_call.test2_HIDE_STAMP)
+
+File "test_assume_on_call.ml", line 11, characters 2-36:
+Error: Unexpected allocation of 24 bytes (test_assume_on_call.ml:11,2--36;test_assume_on_call.ml:1,28--33)
+
+File "test_assume_on_call.ml", line 13, characters 5-15:
+Error: Annotation check for zero_alloc failed on function Test_assume_on_call.test3 (camlTest_assume_on_call.test3_HIDE_STAMP)
+
+File "test_assume_on_call.ml", line 14, characters 2-52:
+Error: Unexpected allocation of 24 bytes (test_assume_on_call.ml:14,2--52;test_assume_on_call.ml:1,28--33)

tests/backend/checkmach/test_misplaced_assume.ml

@@ -0,0 +1,6 @@
+[@@@warnings "+53"]
+
+let[@inline never] bar x = (x,x)
+
+let[@zero_alloc] foo x =
+  ((bar x)[@zero_alloc assume])

tests/backend/checkmach/test_misplaced_assume.output

@@ -0,0 +1,8 @@
+File "test_misplaced_assume.ml", line 6, characters 12-22:
+Warning 53 [misplaced-attribute]: the "zero_alloc" attribute cannot appear in this context
+
+File "test_misplaced_assume.ml", line 5, characters 5-15:
+Error: Annotation check for zero_alloc failed on function Test_misplaced_assume.foo (camlTest_misplaced_assume.foo_HIDE_STAMP)
+
+File "test_misplaced_assume.ml", line 6, characters 2-31:
+Error: Unexpected direct tailcall camlTest_misplaced_assume.bar_HIDE_STAMP