Merge fixes (#21)

* dune file fix for dependency changes * Fix test output (duplicated attributes are no longer ignored) * Refactor checking of flambda-backend-only attrs to match new style
mshinwell · Oct 25, 2022 · 1972f9c · 1972f9c
1 parent 42d94e8
commit 1972f9c
Show file tree

Hide file tree

Showing 5 changed files with 45 additions and 42 deletions.
diff --git a/ocaml/lambda/translattribute.ml b/ocaml/lambda/translattribute.ml
@@ -363,9 +363,11 @@ let add_check_attribute expr loc attributes =
     | Assume p -> Printf.sprintf "%s assume" (to_string p)
     | Default_check -> assert false
   in
-  match expr, get_check_attribute attributes with
-  | expr, [] -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), [check] ->
+  match expr with
+  | Lfunction({ attr = { stub = false } as attr } as funct) ->
+    begin match get_check_attribute attributes with
+    | [] -> expr
+    | [check] ->
       begin match attr.check with
       | Default_check -> ()
       | Assert Noalloc | Assume Noalloc ->
@@ -374,40 +376,36 @@ let add_check_attribute expr loc attributes =
       end;
       let attr = { attr with check } in
       Lfunction { funct with attr }
-  | expr, [check] ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute (to_string check));
-      expr
-  | expr, a::b::_ ->
-    Location.prerr_warning loc
-      (Warnings.Duplicated_attribute
-         (Printf.sprintf "%s/%s"(to_string a) (to_string b)));
-    expr
+    | (_ :: _ :: _) -> assert false
+    end
+  | _ -> expr
 
 let add_poll_attribute expr loc attributes =
-  match expr, get_poll_attribute attributes with
-  | expr, Default_poll -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), poll ->
+  match expr with
+  | Lfunction({ attr = { stub = false } as attr } as funct) ->
+    begin match get_poll_attribute attributes with
+    | Default_poll -> expr
+    | Error_poll as poll ->
       begin match attr.poll with
       | Default_poll -> ()
       | Error_poll ->
-          Location.prerr_warning loc
-            (Warnings.Duplicated_attribute "error_poll")
+        Location.prerr_warning loc
+          (Warnings.Duplicated_attribute "error_poll")
       end;
       let attr = { attr with poll } in
       check_poll_inline loc attr;
       check_poll_local loc attr;
       let attr = { attr with inline = Never_inline; local = Never_local } in
       Lfunction { funct with attr }
-  | expr, Error_poll ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute "error_poll");
-      expr
+    end
+  | _ -> expr
 
 let add_loop_attribute expr loc attributes =
-  match expr, get_loop_attribute attributes with
-  | expr, Default_loop -> expr
-  | Lfunction({ attr = { stub = false } as attr } as funct), loop ->
+  match expr with
+  | Lfunction({ attr = { stub = false } as attr } as funct) ->
+    begin match get_loop_attribute attributes with
+    | Default_loop -> expr
+    | (Always_loop | Never_loop) as loop ->
       begin match attr.loop with
       | Default_loop -> ()
       | Always_loop | Never_loop ->
@@ -416,10 +414,8 @@ let add_loop_attribute expr loc attributes =
       end;
       let attr = { attr with loop } in
       Lfunction { funct with attr = attr }
-  | expr, (Always_loop | Never_loop) ->
-      Location.prerr_warning loc
-        (Warnings.Misplaced_attribute "loop");
-      expr
+    end
+  | _ -> expr
 
 (* Get the [@inlined] attribute payload (or default if not present). *)
 let get_inlined_attribute e =

diff --git a/ocaml/otherlibs/dynlink/dune b/ocaml/otherlibs/dynlink/dune
@@ -355,14 +355,10 @@
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Location.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ident.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Longident.cmo
-  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Builtin_attributes.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Compilation_unit.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Linkage_name.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Symbol.cmo
-  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Type_immediacy.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Path.cmo
-  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo
-  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Types.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Syntaxerr.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Bytesections.cmo
@@ -375,6 +371,10 @@
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Persistent_env.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Docstrings.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ast_helper.cmo
+  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Builtin_attributes.cmo
+  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Type_immediacy.cmo
+  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Attr_helper.cmo
+  .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Primitive.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Predef.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ast_mapper.cmo
   .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Subst.cmo
@@ -413,14 +413,10 @@
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Location.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ident.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Longident.cmx
-  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Builtin_attributes.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Compilation_unit.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Linkage_name.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Symbol.cmx
-  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Type_immediacy.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Path.cmx
-  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx
-  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Types.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Syntaxerr.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Bytesections.cmx
@@ -433,6 +429,10 @@
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Persistent_env.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Docstrings.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ast_helper.cmx
+  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Builtin_attributes.cmx
+  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Type_immediacy.cmx
+  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Attr_helper.cmx
+  .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Primitive.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Predef.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ast_mapper.cmx
   .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Subst.cmx

diff --git a/ocaml/testsuite/tests/warnings/w53.compilers.reference b/ocaml/testsuite/tests/warnings/w53.compilers.reference
@@ -6,10 +6,6 @@ File "w53.ml", line 12, characters 4-5:
 12 | let h x = x [@inline] (* rejected *)
          ^
 Warning 32 [unused-value-declaration]: unused value h.
-File "w53.ml", line 334, characters 2-33:
-334 |   let x : int64 = 42L [@@noalloc] (* rejected *)
-        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
-Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context
 File "w53.ml", line 12, characters 14-20:
 12 | let h x = x [@inline] (* rejected *)
                    ^^^^^^
@@ -562,6 +558,10 @@ File "w53.ml", line 333, characters 19-26:
 333 |   type s1 = Foo1 [@noalloc] (* rejected *)
                          ^^^^^^^
 Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context
+File "w53.ml", line 334, characters 25-32:
+334 |   let x : int64 = 42L [@@noalloc] (* rejected *)
+                               ^^^^^^^
+Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context
 File "w53.ml", line 336, characters 46-53:
 336 |   external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *)
                                                     ^^^^^^^

diff --git a/tests/backend/checkmach/dune b/tests/backend/checkmach/dune
@@ -100,8 +100,13 @@
  (enabled_if (= %{context_name} "main"))
  (targets test_attribute_error_duplicate.output.corrected)
  (deps test_attribute_error_duplicate.ml)
- (action    (with-outputs-to test_attribute_error_duplicate.output.corrected
-            (run %{bin:ocamlopt.opt} %{deps} -color never -error-style short -c -alloc-check -O3))))
+ (action
+   (with-outputs-to test_attribute_error_duplicate.output.corrected
+    (pipe-outputs
+    (with-accepted-exit-codes 2
+     (run %{bin:ocamlopt.opt} %{deps} -color never -error-style short -c -alloc-check -O3))
+    (run "./filter.sh")
+  ))))
 
 (rule
  (alias   runtest)

diff --git a/tests/backend/checkmach/test_attribute_error_duplicate.output b/tests/backend/checkmach/test_attribute_error_duplicate.output
@@ -5,3 +5,5 @@ Warning 54 [duplicated-attribute]: the "noalloc" attribute is used more than onc
 File "test_attribute_error_duplicate.ml", line 3, characters 5-12:
 Warning 47 [attribute-payload]: illegal payload for attribute 'noalloc'.
 It must be either 'assume' or empty
+File "test_attribute_error_duplicate.ml", line 1, characters 30-37:
+Error: Annotation check for noalloc failed on function camlTest_attribute_error_duplicate__test1_HIDE_STAMP