Don't track attributes inside attributes for warning 53 (#115)

This fixes attribute tracking both for serialized ast files and for attributes within attributes.

Author: ccasin

.depend

@@ -300,7 +300,6 @@ parsing/ast_mapper.cmo : \
     utils/load_path.cmi \
     utils/config.cmi \
     utils/clflags.cmi \
-    parsing/builtin_attributes.cmi \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmi \
     parsing/ast_mapper.cmi
@@ -312,7 +311,6 @@ parsing/ast_mapper.cmx : \
     utils/load_path.cmx \
     utils/config.cmx \
     utils/clflags.cmx \
-    parsing/builtin_attributes.cmx \
     parsing/asttypes.cmi \
     parsing/ast_helper.cmx \
     parsing/ast_mapper.cmi
@@ -346,6 +344,7 @@ parsing/builtin_attributes.cmo : \
     utils/config.cmi \
     utils/clflags.cmi \
     parsing/asttypes.cmi \
+    parsing/ast_iterator.cmi \
     parsing/ast_helper.cmi \
     parsing/builtin_attributes.cmi
 parsing/builtin_attributes.cmx : \
@@ -357,6 +356,7 @@ parsing/builtin_attributes.cmx : \
     utils/config.cmx \
     utils/clflags.cmx \
     parsing/asttypes.cmi \
+    parsing/ast_iterator.cmx \
     parsing/ast_helper.cmx \
     parsing/builtin_attributes.cmi
 parsing/builtin_attributes.cmi : \

.depend.menhir

@@ -1,11 +1,30 @@
-parsing/parser.cmo : parsing/syntaxerr.cmi parsing/parsetree.cmi \
-    parsing/longident.cmi parsing/location.cmi parsing/docstrings.cmi \
-    utils/clflags.cmi parsing/asttypes.cmi parsing/ast_helper.cmi \
+parsing/parser.cmo : \
+    parsing/syntaxerr.cmi \
+    parsing/parsetree.cmi \
+    parsing/longident.cmi \
+    parsing/location.cmi \
+    parsing/extensions.cmi \
+    parsing/docstrings.cmi \
+    utils/clflags.cmi \
+    parsing/builtin_attributes.cmi \
+    parsing/asttypes.cmi \
+    parsing/ast_helper.cmi \
     parsing/parser.cmi
-parsing/parser.cmx : parsing/syntaxerr.cmx parsing/parsetree.cmi \
-    parsing/longident.cmx parsing/location.cmx parsing/docstrings.cmx \
-    utils/clflags.cmx parsing/asttypes.cmi parsing/ast_helper.cmx \
+parsing/parser.cmx : \
+    parsing/syntaxerr.cmx \
+    parsing/parsetree.cmi \
+    parsing/longident.cmx \
+    parsing/location.cmx \
+    parsing/extensions.cmx \
+    parsing/docstrings.cmx \
+    utils/clflags.cmx \
+    parsing/builtin_attributes.cmx \
+    parsing/asttypes.cmi \
+    parsing/ast_helper.cmx \
     parsing/parser.cmi
-parsing/parser.cmi : parsing/parsetree.cmi parsing/location.cmi \
+parsing/parser.cmi : \
+    parsing/parsetree.cmi \
+    parsing/longident.cmi \
+    parsing/location.cmi \
     parsing/docstrings.cmi
-parsing/parser.ml parsing/parser.mli: parsing/ast_helper.cmi parsing/asttypes.cmi utils/clflags.cmi parsing/docstrings.cmi parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi parsing/syntaxerr.cmi
+parsing/parser.ml parsing/parser.mli: parsing/ast_helper.cmi parsing/asttypes.cmi parsing/builtin_attributes.cmi utils/clflags.cmi parsing/docstrings.cmi parsing/extensions.cmi parsing/location.cmi parsing/longident.cmi parsing/parsetree.cmi parsing/syntaxerr.cmi

boot/menhir/parser.ml

@@ -61,14 +61,14 @@ PARSING = \
   parsing/ast_helper.cmo \
   parsing/extensions_parsing.cmo parsing/extensions.cmo \
   parsing/pprintast.cmo \
+  parsing/ast_iterator.cmo \
   parsing/builtin_attributes.cmo \
   parsing/camlinternalMenhirLib.cmo \
   parsing/parser.cmo \
   parsing/lexer.cmo \
   parsing/parse.cmo \
   parsing/printast.cmo \
   parsing/ast_mapper.cmo \
-  parsing/ast_iterator.cmo \
   parsing/attr_helper.cmo \
   parsing/ast_invariants.cmo \
   parsing/depend.cmo

compilerlibs/Makefile.compilerlibs

@@ -187,7 +187,9 @@ let file_aux ~tool_name inputfile (type a) parse_fun invariant_fun
         Location.input_lexbuf := Some lexbuf;
         Profile.record_call "parser" (fun () -> parse_fun lexbuf)
       end
-    with x -> close_in ic; raise x
+    with x ->
+      close_in ic;
+      raise x
   in
   close_in ic;
   Profile.record_call "-ppx" (fun () ->

driver/pparse.ml

@@ -67,7 +67,7 @@
 
    ;; PARSING
    location longident docstrings syntaxerr ast_helper camlinternalMenhirLib
-   parser lexer parse printast pprintast ast_mapper ast_iterator attr_helper
+   ast_iterator parser lexer parse printast pprintast ast_mapper attr_helper
    builtin_attributes ast_invariants depend extensions_parsing extensions
    ; manual update: mli only files
    asttypes parsetree

dune

@@ -96,6 +96,7 @@ COMPILERLIBS_SOURCES=\
   parsing/docstrings.ml \
   parsing/syntaxerr.ml \
   parsing/ast_helper.ml \
+  parsing/ast_iterator.ml \
   parsing/builtin_attributes.ml \
   parsing/ast_mapper.ml \
   parsing/attr_helper.ml \

otherlibs/dynlink/Makefile

@@ -41,6 +41,7 @@
     longident
     docstrings
     syntaxerr
+    ast_iterator
     ast_helper
     ast_mapper
     attr_helper
@@ -120,6 +121,7 @@
 (copy_files ../../parsing/longident.ml)
 (copy_files ../../parsing/docstrings.ml)
 (copy_files ../../parsing/syntaxerr.ml)
+(copy_files ../../parsing/ast_iterator.ml)
 (copy_files ../../parsing/ast_helper.ml)
 (copy_files ../../parsing/ast_mapper.ml)
 (copy_files ../../parsing/attr_helper.ml)
@@ -172,6 +174,7 @@
 (copy_files ../../parsing/longident.mli)
 (copy_files ../../parsing/docstrings.mli)
 (copy_files ../../parsing/syntaxerr.mli)
+(copy_files ../../parsing/ast_iterator.mli)
 (copy_files ../../parsing/ast_helper.mli)
 (copy_files ../../parsing/ast_mapper.mli)
 (copy_files ../../parsing/attr_helper.mli)
@@ -273,6 +276,7 @@
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Lazy_backtrack.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Persistent_env.cmo
       .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Docstrings.cmo
+      .dynlink_compilerlibs.objs/byte/dynlink_compilerlibs__Ast_iterator.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
@@ -340,6 +344,7 @@
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Lazy_backtrack.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Persistent_env.cmx
       .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Docstrings.cmx
+      .dynlink_compilerlibs.objs/native/dynlink_compilerlibs__Ast_iterator.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

otherlibs/dynlink/dune

@@ -57,10 +57,6 @@ end
 
 (** {1 Attributes} *)
 module Attr : sig
-  (** This should be used by all external tools (e.g., ppxs) to create
-      attributes.  Inside the compiler, this should be used only when it is
-      known the attribute does not need to be tracked for misplaced attribute
-      warnings.  Otherwise, use [Builtin_attributes.mk_internal]. *)
   val mk: ?loc:loc -> str -> payload -> attribute
 end
 

parsing/ast_helper.mli

@@ -184,8 +184,12 @@ let iterator =
            subtypes is not allowed."
   in
   let attribute self attr =
-    super.attribute self attr;
-    Builtin_attributes.register_attr attr.attr_name
+    (* The change to `self` here avoids registering attributes within attributes
+       for the purposes of warning 53, while keeping all the other invariant
+       checks for attribute payloads.  See comment on [attr_tracking_time] in
+       [builtin_attributes.mli]. *)
+    super.attribute { self with attribute = super.attribute } attr;
+    Builtin_attributes.(register_attr Invariant_check attr.attr_name)
   in
   { super with
     type_declaration

parsing/ast_invariants.ml

@@ -769,7 +769,7 @@ let extension_of_error {kind; main; sub} =
         List.map (fun msg -> Str.extension (extension_of_sub msg)) sub)
 
 let attribute_of_warning loc s =
-  Builtin_attributes.mk_internal
+  Attr.mk
     {loc; txt = "ocaml.ppwarning" }
     (PStr ([Str.eval ~loc (Exp.constant (Pconst_string (s, loc, None)))]))
 

parsing/ast_mapper.ml

@@ -92,14 +92,14 @@ let builtin_attrs =
 
 let is_builtin_attr s = Hashtbl.mem builtin_attrs s
 
-let register_attr name =
-  if is_builtin_attr name.txt
-  then Attribute_table.replace unused_attrs name ()
-
-let mk_internal ?(loc= !default_loc) name payload =
-  register_attr name;
-  Attr.mk ~loc name payload
+type attr_tracking_time = Parser | Invariant_check
 
+let register_attr attr_tracking_time name =
+  match attr_tracking_time with
+  | Parser when !Clflags.all_ppx <> [] -> ()
+  | Parser | Invariant_check ->
+    if is_builtin_attr name.txt then
+      Attribute_table.replace unused_attrs name ()
 
 let ident_of_payload = function
   | PStr[{pstr_desc=Pstr_eval({pexp_desc=Pexp_ident {txt=Lident id}},_)}] ->
@@ -220,6 +220,16 @@ let mark_warn_on_literal_pattern_used l =
     | _ -> ())
     l
 
+let mark_payload_attrs_used payload =
+  let iter =
+    { Ast_iterator.default_iterator
+      with attribute = fun self a ->
+        mark_used a.attr_name;
+        Ast_iterator.default_iterator.attribute self a
+    }
+  in
+  iter.payload iter payload
+
 let alerts_of_attrs l =
   List.fold_left
     (fun acc (_, kind, message) ->

parsing/builtin_attributes.ml

@@ -39,16 +39,26 @@
 *)
 
 
-(** Used by the compiler for attributes that may be compiler built-ins.  These
-    are tracked for misplaced attribute warnings.  This should be used rather
-    than Attr.mk for all built-in attributes. *)
-val mk_internal:
-  ?loc:Location.t -> string Location.loc -> Parsetree.payload ->
-  Parsetree.attribute
-
-(** Used to record attributes that should be tracked for the purpose of
-    misplaced attribute warnings.  *)
-val register_attr: string Location.loc -> unit
+(** [register_attr] must be called on the locations of all attributes that
+    should be tracked for the purpose of misplaced attribute warnings.  In
+    particular, it should be called on all attributes that are present in the
+    source program except those that are contained in the payload of another
+    attribute (because these may be left behind by a ppx and intentionally
+    ignored by the compiler).
+
+    The [attr_tracking_time] argument indicates when the attr is being added for
+    tracking - either when it is created in the parser or when we see it while
+    running the check in the [Ast_invariants] module.  This ensures that we
+    track only attributes from the final version of the parse tree: we skip
+    adding attributes at parse time if we can see that a ppx will be run later,
+    because the [Ast_invariants] check is always run on the result of a ppx.
+
+    Note that the [Ast_invariants] check is also run on parse trees created from
+    marshalled ast files if no ppx is being used, ensuring we don't miss
+    attributes in that case.
+*)
+type attr_tracking_time = Parser | Invariant_check
+val register_attr : attr_tracking_time -> string Location.loc -> unit
 
 (** Marks alert attributes used for the purposes of misplaced attribute
     warnings.  Call this when moving things with alert attributes into the
@@ -61,6 +71,13 @@ val mark_alerts_used : Parsetree.attributes -> unit
     attributes into the environment. *)
 val mark_warn_on_literal_pattern_used : Parsetree.attributes -> unit
 
+(** Marks the attributes hiding in the payload of another attribute used, for
+    the purposes of misplaced attribute warnings (see comment on
+    [attr_tracking_time] above).  In the parser, it's simplest to add these to
+    the table and remove them later, rather than threading through state
+    tracking whether we're in an attribute payload. *)
+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

parsing/builtin_attributes.mli

@@ -151,8 +151,12 @@ let mkuplus ~oploc name arg =
 
 let local_ext_loc loc = mkloc "extension.local" loc
 
+let mk_attr ~loc name payload =
+  Builtin_attributes.(register_attr Parser name);
+  Attr.mk ~loc name payload
+
 let local_attr loc =
-  Builtin_attributes.mk_internal ~loc (local_ext_loc loc) (PStr [])
+  mk_attr ~loc (local_ext_loc loc) (PStr [])
 
 let local_extension loc =
   Exp.mk ~loc:Location.none
@@ -161,8 +165,7 @@ let local_extension loc =
 let include_functor_ext_loc loc = mkloc "extension.include_functor" loc
 
 let include_functor_attr loc =
-  Builtin_attributes.mk_internal ~loc:loc (include_functor_ext_loc loc)
-    (PStr [])
+  mk_attr ~loc:loc (include_functor_ext_loc loc) (PStr [])
 
 let mkexp_stack ~loc ~kwd_loc exp =
   ghexp ~loc (Pexp_apply(local_extension (make_loc kwd_loc), [Nolabel, exp]))
@@ -189,8 +192,7 @@ let wrap_exp_local_if p exp loc =
   if p then wrap_exp_stack exp (make_loc loc) else exp
 
 let curry_attr loc =
-  Builtin_attributes.mk_internal ~loc:Location.none
-    (mkloc "extension.curry" loc) (PStr [])
+  mk_attr ~loc:Location.none (mkloc "extension.curry" loc) (PStr [])
 
 let is_curry_attr attr =
   attr.attr_name.txt = "extension.curry"
@@ -208,12 +210,12 @@ let maybe_curry_typ typ loc =
 let global_loc loc = mkloc "extension.global" loc
 
 let global_attr loc =
-  Builtin_attributes.mk_internal ~loc:loc (global_loc loc) (PStr [])
+  mk_attr ~loc:loc (global_loc loc) (PStr [])
 
 let nonlocal_loc loc = mkloc "extension.nonlocal" loc
 
 let nonlocal_attr loc =
-  Builtin_attributes.mk_internal ~loc:Location.none (nonlocal_loc loc) (PStr [])
+  mk_attr ~loc:Location.none (nonlocal_loc loc) (PStr [])
 
 let mkld_global ld loc =
   { ld with pld_attributes = global_attr loc :: ld.pld_attributes }
@@ -4177,17 +4179,17 @@ attr_id:
   ) { $1 }
 ;
 attribute:
-  LBRACKETAT attr_id payload RBRACKET
-    { Builtin_attributes.mk_internal ~loc:(make_loc $sloc) $2 $3 }
+  LBRACKETAT attr_id attr_payload RBRACKET
+    { mk_attr ~loc:(make_loc $sloc) $2 $3 }
 ;
 post_item_attribute:
-  LBRACKETATAT attr_id payload RBRACKET
-    { Builtin_attributes.mk_internal ~loc:(make_loc $sloc) $2 $3 }
+  LBRACKETATAT attr_id attr_payload RBRACKET
+    { mk_attr ~loc:(make_loc $sloc) $2 $3 }
 ;
 floating_attribute:
-  LBRACKETATATAT attr_id payload RBRACKET
+  LBRACKETATATAT attr_id attr_payload RBRACKET
     { mark_symbol_docs $sloc;
-      Builtin_attributes.mk_internal ~loc:(make_loc $sloc) $2 $3 }
+      mk_attr ~loc:(make_loc $sloc) $2 $3 }
 ;
 %inline post_item_attributes:
   post_item_attribute*
@@ -4227,4 +4229,10 @@ payload:
   | QUESTION pattern { PPat ($2, None) }
   | QUESTION pattern WHEN seq_expr { PPat ($2, Some $4) }
 ;
+attr_payload:
+  payload
+    { Builtin_attributes.mark_payload_attrs_used $1;
+      $1
+    }
+;
 %%

parsing/parser.mly

@@ -0,0 +1,4 @@
+let w53_ast =
+  Pparse.parse_implementation ~tool_name:"w53_test" "w53.ml"
+
+let () = Pparse.write_ast Pparse.Structure "w53.marshalled.ml" w53_ast

testsuite/tests/warnings/marshall_for_w53.ml

@@ -375,3 +375,6 @@ module TestPollStruct = struct
     "x"
   external z : int64 -> int64 = "x" [@@poll error] (* rejected *)
 end
+
+(* Attributes in attributes shouldn't be tracked for w53 *)
+[@@@foo [@@@deprecated]]